From 4fec6f16243522e3c4b1368e0dbb5fcc2618a80c Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 29 Aug 2019 13:12:06 +0200 Subject: [PATCH 01/13] naively connects big_map to the transpiler --- src/contracts/big_map.ligo | 5 +++++ src/transpiler/transpiler.ml | 3 +++ 2 files changed, 8 insertions(+) create mode 100644 src/contracts/big_map.ligo diff --git a/src/contracts/big_map.ligo b/src/contracts/big_map.ligo new file mode 100644 index 000000000..2b6f97581 --- /dev/null +++ b/src/contracts/big_map.ligo @@ -0,0 +1,5 @@ +type storage_ is big_map(int, int) * unit + +function main(const p : unit; const s : storage_) : list(operation) * storage_ is + block { skip } + with ((nil : list(operation)), s) \ No newline at end of file diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 7d4db9321..3c8ad1ae3 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -113,6 +113,9 @@ let rec translate_type (t:AST.type_value) : type_value result = | T_constant ("map", [key;value]) -> let%bind kv' = bind_map_pair translate_type (key, value) in ok (T_map kv') + | T_constant ("big_map", [key;value] ) -> + let%bind kv' = bind_map_pair translate_type (key, value) in + ok (T_map kv') | T_constant ("list", [t]) -> let%bind t' = translate_type t in ok (T_list t') From 25e3ab8e5d8d49012c914089f9b6492d32e7dfba Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Tue, 3 Sep 2019 18:33:30 +0200 Subject: [PATCH 02/13] big map can be looked up --- src/compiler/compiler_type.ml | 8 ++++++++ src/contracts/big_map.ligo | 19 ++++++++++++++++--- src/mini_c/PP.ml | 1 + src/mini_c/types.ml | 1 + src/transpiler/transpiler.ml | 2 +- src/typer/typer.ml | 2 +- vendors/ligo-utils/simple-utils/trace.ml | 2 ++ 7 files changed, 30 insertions(+), 5 deletions(-) diff --git a/src/compiler/compiler_type.ml b/src/compiler/compiler_type.ml index 4596bd74d..b22a0d2ef 100644 --- a/src/compiler/compiler_type.ml +++ b/src/compiler/compiler_type.ml @@ -70,6 +70,7 @@ module Ty = struct | T_or _ -> fail (not_comparable "or") | T_pair _ -> fail (not_comparable "pair") | T_map _ -> fail (not_comparable "map") + | T_big_map _ -> fail (not_comparable "big_map") | T_list _ -> fail (not_comparable "list") | T_set _ -> fail (not_comparable "set") | T_option _ -> fail (not_comparable "option") @@ -116,6 +117,10 @@ module Ty = struct let%bind (Ex_comparable_ty k') = comparable_type k in let%bind (Ex_ty v') = type_ v in ok @@ Ex_ty (map k' v') + | T_big_map (k, v) -> + let%bind (Ex_comparable_ty k') = comparable_type k in + let%bind (Ex_ty v') = type_ v in + ok @@ Ex_ty (big_map k' v') | T_list t -> let%bind (Ex_ty t') = type_ t in ok @@ Ex_ty (list t') @@ -184,6 +189,9 @@ let rec type_ : type_value -> O.michelson result = | T_map kv -> let%bind (k', v') = bind_map_pair type_ kv in ok @@ O.prim ~children:[k';v'] O.T_map + | T_big_map kv -> + let%bind (k', v') = bind_map_pair type_ kv in + ok @@ O.prim ~children:[k';v'] O.T_big_map | T_list t -> let%bind t' = type_ t in ok @@ O.prim ~children:[t'] O.T_list diff --git a/src/contracts/big_map.ligo b/src/contracts/big_map.ligo index 2b6f97581..2eb21153e 100644 --- a/src/contracts/big_map.ligo +++ b/src/contracts/big_map.ligo @@ -1,5 +1,18 @@ -type storage_ is big_map(int, int) * unit +// type storage_ is big_map(int, int) * unit +type storage_ is big_map(int, int) + +// function main(const p : unit; const s : storage_) : list(operation) * storage_ is +// block { skip } +// with ((nil : list(operation)), s) function main(const p : unit; const s : storage_) : list(operation) * storage_ is - block { skip } - with ((nil : list(operation)), s) \ No newline at end of file + // var r : big_map(int, int) := s.0 ; + var r : big_map(int,int) := s ; + var toto : option (int) := Some(0); + block { + // r[23] := 2; + toto := r[23]; + s := r; + // skip + } + with ((nil: list(operation)), s) \ No newline at end of file diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index 13fb005fc..c7eab992d 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_base b -> type_base ppf 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_big_map(k, v) -> fprintf ppf "big_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 diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index fd0ddd021..8be621954 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -15,6 +15,7 @@ type type_value = | T_deep_closure of environment * type_value * type_value | T_base of type_base | T_map of (type_value * type_value) + | T_big_map of (type_value * type_value) | T_list of type_value | T_set of type_value | T_contract of type_value diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 3c8ad1ae3..a2119fe19 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -115,7 +115,7 @@ let rec translate_type (t:AST.type_value) : type_value result = ok (T_map kv') | T_constant ("big_map", [key;value] ) -> let%bind kv' = bind_map_pair translate_type (key, value) in - ok (T_map kv') + ok (T_big_map kv') | T_constant ("list", [t]) -> let%bind t' = translate_type t in ok (T_list t') diff --git a/src/typer/typer.ml b/src/typer/typer.ml index 5c962cc10..6262f3971 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -614,7 +614,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a return (E_application (f' , arg)) tv | E_look_up dsi -> let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in - let%bind (src, dst) = get_t_map ds.type_annotation in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in return (E_look_up (ds , ind)) (t_option dst ()) (* Advanced *) diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 52637021e..329203a46 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -639,6 +639,8 @@ let bind_or (a, b) = match a with | Ok _ as o -> o | _ -> b +let bind_map_or (fa , fb) c = + bind_or (fa c , fb c) let bind_lr (type a b) ((a : a result), (b:b result)) : [`Left of a | `Right of b] result = match (a, b) with From e930dc00c4ec57e560d99622647ecd70af64627c Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Wed, 4 Sep 2019 19:05:45 +0200 Subject: [PATCH 03/13] some check on starage for big_map --- src/contracts/big_map.ligo | 15 ++++----------- src/operators/operators.ml | 6 +++++- src/transpiler/transpiler.ml | 37 +++++++++++++++++++++++++++++++++++- 3 files changed, 45 insertions(+), 13 deletions(-) diff --git a/src/contracts/big_map.ligo b/src/contracts/big_map.ligo index 2eb21153e..e05d23899 100644 --- a/src/contracts/big_map.ligo +++ b/src/contracts/big_map.ligo @@ -1,18 +1,11 @@ -// type storage_ is big_map(int, int) * unit -type storage_ is big_map(int, int) - -// function main(const p : unit; const s : storage_) : list(operation) * storage_ is -// block { skip } -// with ((nil : list(operation)), s) +// type storage_ is big_map(int, int) +type storage_ is big_map(int, int) * unit function main(const p : unit; const s : storage_) : list(operation) * storage_ is - // var r : big_map(int, int) := s.0 ; - var r : big_map(int,int) := s ; + var r : big_map(int, int) := s.0 ; var toto : option (int) := Some(0); block { - // r[23] := 2; toto := r[23]; - s := r; - // skip + s.0 := r; } with ((nil: list(operation)), s) \ No newline at end of file diff --git a/src/operators/operators.ml b/src/operators/operators.ml index 61495e0e9..d08a535eb 100644 --- a/src/operators/operators.ml +++ b/src/operators/operators.ml @@ -592,7 +592,11 @@ module Typer = struct map_map ; map_fold ; map_iter ; - map_map ; + big_map_remove ; + big_map_add ; + big_map_update ; + big_map_mem ; + big_map_find ; set_empty ; set_mem ; set_add ; diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index a2119fe19..7f63fc378 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -58,6 +58,15 @@ them. please report this to the developers." in ] in error ~data title content + let bad_big_map location = + let title () = "bad arguments for main" in + let content () = "only one big_map per program which must appear + on the left hand side of a pair in the contract's storage" in + let data = [ + ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; + ] in + error ~data title content + let missing_entry_point name = let title () = "missing entry point" in let content () = "no entry point with the given name" in @@ -601,10 +610,36 @@ let translate_program (lst:AST.program) : program result = let%bind (statements, _) = List.fold_left aux (ok ([], Environment.empty)) (temp_unwrap_loc_list lst) in ok statements +(* check whether the storage contains a big_map, if yes, check that + it appears on the left hand side of a pair *) +let check_storage f ty loc : (anon_function * _) result = + let rec aux (t:type_value) on_big_map = + match t with + | T_big_map _ -> on_big_map + | T_pair (a , b) -> (aux a true) && (aux b false) + | T_or (a,b) -> (aux a false) && (aux b false) + | T_function (a,b) -> (aux a false) && (aux b false) + | T_deep_closure (_,a,b) -> (aux a false) && (aux b false) + | T_map (a,b) -> (aux a false) && (aux b false) + | T_list a -> (aux a false) + | T_set a -> (aux a false) + | T_contract a -> (aux a false) + | T_option a -> (aux a false) + | _ -> true + in + match f.result.type_value with + | T_pair (_, storage) -> + if aux storage false then ok (f, ty) else fail @@ bad_big_map loc + | _ -> ok (f, ty) + +(* let translate_main (l:AST.lambda) loc : anon_function result = + let%bind expr = translate_lambda Environment.empty l in + match Combinators.Expression.get_content expr with + | E_literal (D_function f) -> check_storage f loc *) let translate_main (l:AST.lambda) loc : (anon_function * _) result = let%bind expr = translate_lambda Environment.empty l in match expr.content , expr.type_value with - | E_literal (D_function f) , T_function ty -> ok (f , ty) + | E_literal (D_function f) , T_function ty -> check_storage f ty loc | _ -> fail @@ not_functional_main loc (* From an expression [expr], build the expression [fun () -> expr] *) From 1c281ac079e1a4f44cbad8e27d33743e6d46f6a7 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 5 Sep 2019 13:06:48 +0200 Subject: [PATCH 04/13] merge operations syntax for map with big_map --- src/ast_typed/combinators.ml | 14 ++++++------ src/mini_c/combinators.ml | 1 + src/operators/operators.ml | 42 ++++-------------------------------- src/typer/typer.ml | 2 +- 4 files changed, 13 insertions(+), 46 deletions(-) diff --git a/src/ast_typed/combinators.ml b/src/ast_typed/combinators.ml index ec745fabc..f402d253b 100644 --- a/src/ast_typed/combinators.ml +++ b/src/ast_typed/combinators.ml @@ -139,12 +139,13 @@ let get_t_record (t:type_value) : type_value SMap.t result = match t.type_value' let get_t_map (t:type_value) : (type_value * type_value) result = match t.type_value' with | T_constant ("map", [k;v]) -> ok (k, v) - | _ -> simple_fail "get: not a map" - -let get_t_big_map (t:type_value) : (type_value * type_value) result = - match t.type_value' with | T_constant ("big_map", [k;v]) -> ok (k, v) - | _ -> simple_fail "get: not a big_map" + | _ -> simple_fail "get: not a map or a big_map" + +let get_t_map_not_big_map (t:type_value) : (type_value * type_value) result = + match t.type_value' with + | T_constant ("map", [k;v]) -> ok (k, v) + | _ -> simple_fail "get: not a map" let get_t_map_key : type_value -> type_value result = fun t -> let%bind (key , _) = get_t_map t in @@ -158,8 +159,7 @@ let assert_t_map = fun t -> let%bind _ = get_t_map t in ok () -let is_t_map = Function.compose to_bool get_t_map -let is_t_big_map = Function.compose to_bool get_t_big_map +let is_t_map_not_big_map = Function.compose to_bool get_t_map_not_big_map let assert_t_tez : type_value -> unit result = get_t_tez let assert_t_key = get_t_key diff --git a/src/mini_c/combinators.ml b/src/mini_c/combinators.ml index f7342987e..5cc9d2ae4 100644 --- a/src/mini_c/combinators.ml +++ b/src/mini_c/combinators.ml @@ -88,6 +88,7 @@ let get_t_or (t:type_value) = match t with let get_t_map (t:type_value) = match t with | T_map kv -> ok kv + | T_big_map kv -> ok kv | _ -> simple_fail "not a type map" let get_t_list (t:type_value) = match t with diff --git a/src/operators/operators.ml b/src/operators/operators.ml index d08a535eb..3db1919f1 100644 --- a/src/operators/operators.ml +++ b/src/operators/operators.ml @@ -268,20 +268,20 @@ module Typer = struct ok @@ t_option dst () let map_iter : typer = typer_2 "MAP_ITER" @@ fun m f -> - let%bind (k, v) = get_t_map m in + let%bind (k, v) = get_t_map_not_big_map m in let%bind (arg , res) = get_t_function f in let%bind () = assert_eq_1 arg (t_pair k v ()) in let%bind () = assert_eq_1 res (t_unit ()) in ok @@ t_unit () let map_map : typer = typer_2 "MAP_MAP" @@ fun m f -> - let%bind (k, v) = get_t_map m in + let%bind (k, v) = get_t_map_not_big_map m in let%bind (arg , res) = get_t_function f in let%bind () = assert_eq_1 arg (t_pair k v ()) in ok @@ t_map k res () let map_fold : typer = typer_2 "MAP_FOLD" @@ fun f m -> - let%bind (k, v) = get_t_map m in + let%bind (k, v) = get_t_map_not_big_map m in let%bind (arg_1 , res) = get_t_function f in let%bind (arg_2 , res') = get_t_function res in let%bind (arg_3 , res'') = get_t_function res' in @@ -290,39 +290,10 @@ module Typer = struct let%bind () = assert_eq_1 arg_3 res'' in ok @@ res' - let big_map_remove : typer = typer_2 "BIG_MAP_REMOVE" @@ fun k m -> - let%bind (src , _) = get_t_big_map m in - let%bind () = assert_type_value_eq (src , k) in - ok m - - let big_map_add : typer = typer_3 "BIG_MAP_ADD" @@ fun k v m -> - let%bind (src, dst) = get_t_big_map m in - let%bind () = assert_type_value_eq (src, k) in - let%bind () = assert_type_value_eq (dst, v) in - ok m - - let big_map_update : typer = typer_3 "BIG_MAP_UPDATE" @@ fun k v m -> - let%bind (src, dst) = get_t_big_map m in - let%bind () = assert_type_value_eq (src, k) in - let%bind v' = get_t_option v in - let%bind () = assert_type_value_eq (dst, v') in - ok m - - let big_map_mem : typer = typer_2 "BIG_MAP_MEM" @@ fun k m -> - let%bind (src, _dst) = get_t_big_map m in - let%bind () = assert_type_value_eq (src, k) in - ok @@ t_bool () - - let big_map_find : typer = typer_2 "BIG_MAP_FIND" @@ fun k m -> - let%bind (src, dst) = get_t_big_map m in - let%bind () = assert_type_value_eq (src, k) in - ok @@ dst - - let size = typer_1 "SIZE" @@ fun t -> let%bind () = Assert.assert_true @@ - (is_t_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t || is_t_big_map t) in + (is_t_map_not_big_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t) in ok @@ t_nat () let slice = typer_3 "SLICE" @@ fun i j s -> @@ -592,11 +563,6 @@ module Typer = struct map_map ; map_fold ; map_iter ; - big_map_remove ; - big_map_add ; - big_map_update ; - big_map_mem ; - big_map_find ; set_empty ; set_mem ; set_add ; diff --git a/src/typer/typer.ml b/src/typer/typer.ml index 6262f3971..5c962cc10 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -614,7 +614,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a return (E_application (f' , arg)) tv | E_look_up dsi -> let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in - let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in + let%bind (src, dst) = get_t_map ds.type_annotation in let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in return (E_look_up (ds , ind)) (t_option dst ()) (* Advanced *) From a9f7bb39e4dd3bc4444b6cc2d4bbb23e4338e4df Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Thu, 5 Sep 2019 17:23:51 +0200 Subject: [PATCH 05/13] add tests for big_map --- src/contracts/big_map.ligo | 54 ++++++++++++++++++++++++++++++++- src/test/integration_tests.ml | 56 +++++++++++++++++++++++++++++++++++ 2 files changed, 109 insertions(+), 1 deletion(-) diff --git a/src/contracts/big_map.ligo b/src/contracts/big_map.ligo index e05d23899..3e9bf7ef9 100644 --- a/src/contracts/big_map.ligo +++ b/src/contracts/big_map.ligo @@ -8,4 +8,56 @@ function main(const p : unit; const s : storage_) : list(operation) * storage_ i toto := r[23]; s.0 := r; } - with ((nil: list(operation)), s) \ No newline at end of file + with ((nil: list(operation)), s) + + + +// type foobar is map(int, int) + +// const fb : foobar = map +// 23 -> 0 ; +// 42 -> 0 ; +// end + +function set_ (var n : int ; var m : storage_) : storage_ is block { + var tmp : big_map(int,int) := m.0 ; + tmp[23] := n ; + m.0 := tmp ; +} with m + +function rm (var m : storage_) : storage_ is block { + var tmp : big_map(int,int) := m.0 ; + remove 42 from map tmp; + m.0 := tmp; +} with m + +// not supported +// function size_ (const m : storage_) : nat is +// block {skip} with (size(m.0)) + +function gf (const m : storage_) : int is begin skip end with get_force(23, m.0) + +function get (const m : storage_) : option(int) is + begin + skip + end with m.0[42] + +// const bm : storage_ = map +// 144 -> 23 ; +// 51 -> 23 ; +// 42 -> 23 ; +// 120 -> 23 ; +// 421 -> 23 ; +// end + +// not supported +// function iter_op (const m : storage_) : int is +// var r : int := 0 ; +// function aggregate (const i : int ; const j : int) : unit is block { r := r + i + j } with unit ; +// block { +// map_iter(m.0 , aggregate) ; +// } with r ; + +// function map_op (const m : storage_) : storage_ is +// function increment (const i : int ; const j : int) : int is block { skip } with j + 1 ; +// block { skip } with map_map(m.0 , increment) ; diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index baea8d256..dccd6470a 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -392,6 +392,61 @@ let map () : unit result = in ok () +let big_map () : unit result = + let%bind program = type_file "./contracts/big_map.ligo" in + let ez lst = + let open Ast_simplified.Combinators in + let lst' = List.map (fun (x, y) -> e_int x, e_int y) lst in + e_pair (e_typed_map lst' t_int t_int) (e_unit ()) + in + let%bind () = + let make_input = fun n -> ez [(23, n) ; (42, 4)] in + let make_expected = e_int in + expect_eq_n program "gf" make_input make_expected + in + (* let%bind () = + let make_input = fun n -> ez List.(map (fun x -> (x, x)) @@ range n) in + let make_expected = e_nat in + expect_eq_n_strict_pos_small program "size_" make_input make_expected + in + let%bind () = + let expected = ez [(23, 0) ; (42, 0)] in + expect_eq_evaluate program "fb" expected + in + let%bind () = + let make_input = fun n -> + let m = ez [(23 , 0) ; (42 , 0)] in + e_tuple [(e_int n) ; m] + in + let make_expected = fun n -> ez [(23 , n) ; (42 , 0)] in + expect_eq_n_pos_small program "set_" make_input make_expected + in + let%bind () = + let make_input = fun n -> ez [(23, n) ; (42, 4)] in + let make_expected = fun _ -> e_some @@ e_int 4 in + expect_eq_n program "get" make_input make_expected + in + let%bind () = + let expected = ez @@ List.map (fun x -> (x, 23)) [144 ; 51 ; 42 ; 120 ; 421] in + expect_eq_evaluate program "bm" expected + in + let%bind () = + let input = ez [(23, 23) ; (42, 42)] in + let expected = ez [23, 23] in + expect_eq program "rm" input expected + in *) + (* let%bind () = + let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in + let expected = e_int 66 in + expect_eq program "iter_op" input expected + in + let%bind () = + let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in + let expected = ez [(1 , 11) ; (2 , 21) ; (3 , 31) ] in + expect_eq program "map_op" input expected + in *) + ok () + let list () : unit result = let%bind program = type_file "./contracts/list.ligo" in let ez lst = @@ -690,6 +745,7 @@ let main = test_suite "Integration (End to End)" [ test "string" string_expression ; test "option" option ; test "map" map ; + test "big_map" big_map ; test "list" list ; test "loop" loop ; test "matching" matching ; From e5b4d37af8d1974d362b903741419d7911016631 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 6 Sep 2019 15:43:11 +0200 Subject: [PATCH 06/13] add E_big_map case in Ast --- src/ast_simplified/PP.ml | 1 + src/ast_simplified/combinators.ml | 3 +++ src/ast_simplified/misc.ml | 4 ++-- src/ast_simplified/types.ml | 1 + src/ast_typed/PP.ml | 1 + src/ast_typed/combinators.ml | 1 + src/ast_typed/misc.ml | 6 +++--- src/ast_typed/misc_smart.ml | 2 +- src/ast_typed/types.ml | 1 + src/test/integration_tests.ml | 2 +- src/transpiler/transpiler.ml | 14 ++++++++++++- src/typer/typer.ml | 33 +++++++++++++++++++++++++++++++ 12 files changed, 61 insertions(+), 8 deletions(-) diff --git a/src/ast_simplified/PP.ml b/src/ast_simplified/PP.ml index 07277c664..4ab2bdde8 100644 --- a/src/ast_simplified/PP.ml +++ b/src/ast_simplified/PP.ml @@ -41,6 +41,7 @@ let rec expression ppf (e:expression) = match Location.unwrap e with | E_accessor (ae, p) -> fprintf ppf "%a.%a" expression ae access_path p | 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_big_map m -> fprintf ppf "big_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 diff --git a/src/ast_simplified/combinators.ml b/src/ast_simplified/combinators.ml index 622e1039c..4680056e5 100644 --- a/src/ast_simplified/combinators.ml +++ b/src/ast_simplified/combinators.ml @@ -43,6 +43,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_big_map key value = (T_constant ("big_map", [key ; value])) let t_set key = (T_constant ("set", [key])) let make_name (s : string) : name = s @@ -66,6 +67,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_big_map ?loc lst : expression = Location.wrap ?loc @@ E_big_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] @@ -106,6 +108,7 @@ 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_big_map ?loc lst k v = e_annotation ?loc (e_big_map lst) (t_big_map k v) let e_typed_set ?loc lst k = e_annotation ?loc (e_set lst) (t_set k) diff --git a/src/ast_simplified/misc.ml b/src/ast_simplified/misc.ml index e1582b073..5dd52417b 100644 --- a/src/ast_simplified/misc.ml +++ b/src/ast_simplified/misc.ml @@ -120,7 +120,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = | E_record _, _ -> simple_fail "comparing record with other stuff" - | E_map lsta, E_map lstb -> ( + | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( let%bind lst = generic_try (simple_error "maps of different lengths") (fun () -> let lsta' = List.sort compare lsta in @@ -133,7 +133,7 @@ let rec assert_value_eq (a, b: (expression * expression )) : unit result = let%bind _all = bind_map_list aux lst in ok () ) - | E_map _, _ -> + | (E_map _ | E_big_map _), _ -> simple_fail "comparing map with other stuff" | E_list lsta, E_list lstb -> ( diff --git a/src/ast_simplified/types.ml b/src/ast_simplified/types.ml index 88b93beda..1e8104a79 100644 --- a/src/ast_simplified/types.ml +++ b/src/ast_simplified/types.ml @@ -59,6 +59,7 @@ and expression' = | E_accessor of (expr * access_path) (* Data Structures *) | E_map of (expr * expr) list + | E_big_map of (expr * expr) list | E_list of expr list | E_set of expr list | E_look_up of (expr * expr) diff --git a/src/ast_typed/PP.ml b/src/ast_typed/PP.ml index 3e8edf30c..141cc768a 100644 --- a/src/ast_typed/PP.ml +++ b/src/ast_typed/PP.ml @@ -42,6 +42,7 @@ and expression ppf (e:expression) : unit = | E_tuple lst -> fprintf ppf "tuple[@; @[%a@]@;]" (list_sep annotated_expression (tag ",@;")) lst | 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_big_map m -> fprintf ppf "big_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 diff --git a/src/ast_typed/combinators.ml b/src/ast_typed/combinators.ml index f402d253b..78aa8a4a6 100644 --- a/src/ast_typed/combinators.ml +++ b/src/ast_typed/combinators.ml @@ -41,6 +41,7 @@ let ez_t_record lst ?s () : type_value = t_record m ?s () let t_map key value ?s () = make_t (T_constant ("map", [key ; value])) s +let t_big_map key value ?s () = make_t (T_constant ("big_map", [key ; value])) s let t_sum m ?s () : type_value = make_t (T_sum m) s let make_t_ez_sum (lst:(string * type_value) list) : type_value = diff --git a/src/ast_typed/misc.ml b/src/ast_typed/misc.ml index 091531789..8ea8c1bba 100644 --- a/src/ast_typed/misc.ml +++ b/src/ast_typed/misc.ml @@ -156,7 +156,7 @@ module Free_variables = struct | 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_map m | E_big_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) | E_failwith a -> self a @@ -422,7 +422,7 @@ let rec assert_value_eq (a, b: (value*value)) : unit result = | E_record _, _ -> fail @@ (different_values_because_different_types "record vs. non-record" a b) - | E_map lsta, E_map lstb -> ( + | (E_map lsta, E_map lstb | E_big_map lsta, E_big_map lstb) -> ( let%bind lst = generic_try (different_size_values "maps of different lengths" a b) (fun () -> let lsta' = List.sort compare lsta in @@ -435,7 +435,7 @@ let rec assert_value_eq (a, b: (value*value)) : unit result = let%bind _all = bind_map_list aux lst in ok () ) - | E_map _, _ -> + | (E_map _ | E_big_map _), _ -> fail @@ different_values_because_different_types "map vs. non-map" a b | E_list lsta, E_list lstb -> ( diff --git a/src/ast_typed/misc_smart.ml b/src/ast_typed/misc_smart.ml index 0d0e8cd02..8ff87c9f6 100644 --- a/src/ast_typed/misc_smart.ml +++ b/src/ast_typed/misc_smart.ml @@ -80,7 +80,7 @@ module Captured_variables = struct | E_set lst -> let%bind lst' = bind_map_list self lst in ok @@ unions lst' - | E_map m -> + | (E_map m | E_big_map m) -> let%bind lst' = bind_map_list self @@ List.concat @@ List.map (fun (a, b) -> [ a ; b ]) m in ok @@ unions lst' | E_look_up (a , b) -> diff --git a/src/ast_typed/types.ml b/src/ast_typed/types.ml index cf8c40fec..a56843eca 100644 --- a/src/ast_typed/types.ml +++ b/src/ast_typed/types.ml @@ -99,6 +99,7 @@ and expression = | E_record_accessor of (ae * string) (* Data Structures *) | E_map of (ae * ae) list + | E_big_map of (ae * ae) list | E_list of ae list | E_set of ae list | E_look_up of (ae * ae) diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index dccd6470a..c08a18d55 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -397,7 +397,7 @@ let big_map () : unit result = let ez lst = let open Ast_simplified.Combinators in let lst' = List.map (fun (x, y) -> e_int x, e_int y) lst in - e_pair (e_typed_map lst' t_int t_int) (e_unit ()) + e_pair (e_typed_big_map lst' t_int t_int) (e_unit ()) in let%bind () = let make_input = fun n -> ez [(23, n) ; (42, 4)] in diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 7f63fc378..ff80c19c8 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -434,7 +434,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind (init : expression) = return @@ E_make_empty_set t in bind_fold_list aux init lst' ) - | E_map m -> ( + | (E_map m | E_big_map m) -> ( let%bind (src, dst) = trace_strong (corner_case ~loc:__LOC__ "not a map") @@ Mini_c.Combinators.get_t_map tv in @@ -802,6 +802,18 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression bind_map_list aux lst in return (E_map lst') ) + | T_constant ("big_map", [k_ty;v_ty]) -> ( + let%bind lst = + trace_strong (wrong_mini_c_value "map" v) @@ + 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 (E_big_map lst') + ) | T_constant ("list", [ty]) -> ( let%bind lst = trace_strong (wrong_mini_c_value "list" v) @@ diff --git a/src/typer/typer.ml b/src/typer/typer.ml index 5c962cc10..c95ec44fb 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -556,6 +556,36 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a ok (t_map key_type value_type ()) in return (E_map lst') tv + | E_big_map lst -> + let%bind lst' = bind_map_list (bind_map_pair (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 key_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map fst lst' in + let%bind annot = bind_map_option get_t_map_key tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") + in + let%bind value_type = + let%bind sub = + bind_fold_list aux None + @@ List.map get_type_annotation + @@ List.map snd lst' in + let%bind annot = bind_map_option get_t_map_value tv_opt in + trace (simple_info "empty map expression without a type annotation") @@ + O.merge_annotation annot sub (needs_annotation ae "this map literal") + in + ok (t_big_map key_type value_type ()) + in + return (E_big_map lst') tv | E_lambda { binder ; input_type ; @@ -826,6 +856,9 @@ let rec untype_expression (e:O.annotated_expression) : (I.expression) result = | E_map m -> let%bind m' = bind_map_list (bind_map_pair untype_expression) m in return (e_map m') + | E_big_map m -> + let%bind m' = bind_map_list (bind_map_pair untype_expression) m in + return (e_big_map m') | E_list lst -> let%bind lst' = bind_map_list untype_expression lst in return (e_list lst') From c7cfce2bf774bba22f397ff0412869ff86c0e477 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Mon, 9 Sep 2019 22:23:29 +0200 Subject: [PATCH 07/13] Remove merge comments --- src/transpiler/transpiler.ml | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index ff80c19c8..56da73d5e 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -632,10 +632,6 @@ let check_storage f ty loc : (anon_function * _) result = if aux storage false then ok (f, ty) else fail @@ bad_big_map loc | _ -> ok (f, ty) -(* let translate_main (l:AST.lambda) loc : anon_function result = - let%bind expr = translate_lambda Environment.empty l in - match Combinators.Expression.get_content expr with - | E_literal (D_function f) -> check_storage f loc *) let translate_main (l:AST.lambda) loc : (anon_function * _) result = let%bind expr = translate_lambda Environment.empty l in match expr.content , expr.type_value with From 304184bcd3ae5366327e857cd5401662c1a2fc15 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Wed, 11 Sep 2019 16:02:06 +0200 Subject: [PATCH 08/13] Bla --- src/ast_typed/combinators.ml | 22 +++++++++++++++------- src/compiler/compiler_program.ml | 11 ++++++++++- src/mini_c/PP.ml | 1 + src/mini_c/combinators.ml | 9 ++++++++- src/mini_c/types.ml | 1 + src/operators/operators.ml | 26 +++++++++++++------------- src/transpiler/transpiler.ml | 20 +++++++++++++++++--- src/typer/typer.ml | 8 ++++---- 8 files changed, 69 insertions(+), 29 deletions(-) diff --git a/src/ast_typed/combinators.ml b/src/ast_typed/combinators.ml index 78aa8a4a6..32e25f2ec 100644 --- a/src/ast_typed/combinators.ml +++ b/src/ast_typed/combinators.ml @@ -138,16 +138,15 @@ let get_t_record (t:type_value) : type_value SMap.t result = match t.type_value' | _ -> simple_fail "not a record type" let get_t_map (t:type_value) : (type_value * type_value) result = - match t.type_value' with - | T_constant ("map", [k;v]) -> ok (k, v) - | T_constant ("big_map", [k;v]) -> ok (k, v) - | _ -> simple_fail "get: not a map or a big_map" - -let get_t_map_not_big_map (t:type_value) : (type_value * type_value) result = match t.type_value' with | T_constant ("map", [k;v]) -> ok (k, v) | _ -> simple_fail "get: not a map" +let get_t_big_map (t:type_value) : (type_value * type_value) result = + match t.type_value' with + | T_constant ("big_map", [k;v]) -> ok (k, v) + | _ -> simple_fail "get: not a big_map" + let get_t_map_key : type_value -> type_value result = fun t -> let%bind (key , _) = get_t_map t in ok key @@ -156,11 +155,20 @@ let get_t_map_value : type_value -> type_value result = fun t -> let%bind (_ , value) = get_t_map t in ok value +let get_t_big_map_key : type_value -> type_value result = fun t -> + let%bind (key , _) = get_t_big_map t in + ok key + +let get_t_big_map_value : type_value -> type_value result = fun t -> + let%bind (_ , value) = get_t_big_map t in + ok value + let assert_t_map = fun t -> let%bind _ = get_t_map t in ok () -let is_t_map_not_big_map = Function.compose to_bool get_t_map_not_big_map +let is_t_map = Function.compose to_bool get_t_map +let is_t_big_map = Function.compose to_bool get_t_big_map let assert_t_tez : type_value -> unit result = get_t_tez let assert_t_key = get_t_key diff --git a/src/compiler/compiler_program.ml b/src/compiler/compiler_program.ml index 789000391..83d80e1b9 100644 --- a/src/compiler/compiler_program.ml +++ b/src/compiler/compiler_program.ml @@ -35,7 +35,7 @@ let get_predicate : string -> type_value -> expression list -> predicate result | "MAP_REMOVE" -> let%bind v = match lst with | [ _ ; expr ] -> - let%bind (_, v) = Mini_c.Combinators.(get_t_map (Expression.get_type expr)) in + let%bind (_, v) = Mini_c.Combinators.(bind_map_or (get_t_map , get_t_big_map) (Expression.get_type expr)) in ok v | _ -> simple_fail "mini_c . MAP_REMOVE" in let%bind v_ty = Compiler_type.type_ v in @@ -107,6 +107,15 @@ let rec translate_value (v:value) ty : michelson result = match v with let aux (a, b) = prim ~children:[a;b] D_Elt in ok @@ seq @@ List.map aux sorted ) + | D_big_map lst -> ( + let%bind (k_ty , v_ty) = get_t_big_map ty in + let%bind lst' = + let aux (k , v) = bind_pair (translate_value k k_ty , translate_value v v_ty) in + bind_map_list aux lst in + let sorted = List.sort (fun (x , _) (y , _) -> compare x y) lst' in + let aux (a, b) = prim ~children:[a;b] D_Elt in + ok @@ seq @@ List.map aux sorted + ) | D_list lst -> ( let%bind e_ty = get_t_list ty in let%bind lst' = bind_map_list (fun x -> translate_value x e_ty) lst in diff --git a/src/mini_c/PP.ml b/src/mini_c/PP.ml index c7eab992d..46f39f766 100644 --- a/src/mini_c/PP.ml +++ b/src/mini_c/PP.ml @@ -62,6 +62,7 @@ let rec value ppf : value -> unit = function | D_none -> fprintf ppf "None" | D_some s -> fprintf ppf "Some (%a)" value s | D_map m -> fprintf ppf "Map[%a]" (list_sep_d value_assoc) m + | D_big_map m -> fprintf ppf "Big_map[%a]" (list_sep_d value_assoc) m | D_list lst -> fprintf ppf "List[%a]" (list_sep_d value) lst | D_set lst -> fprintf ppf "Set[%a]" (list_sep_d value) lst diff --git a/src/mini_c/combinators.ml b/src/mini_c/combinators.ml index 5cc9d2ae4..f2639ebf6 100644 --- a/src/mini_c/combinators.ml +++ b/src/mini_c/combinators.ml @@ -62,6 +62,10 @@ let get_map (v:value) = match v with | D_map lst -> ok lst | _ -> simple_fail "not a map" +let get_big_map (v:value) = match v with + | D_big_map lst -> ok lst + | _ -> simple_fail "not a big_map" + let get_list (v:value) = match v with | D_list lst -> ok lst | _ -> simple_fail "not a list" @@ -88,9 +92,12 @@ let get_t_or (t:type_value) = match t with let get_t_map (t:type_value) = match t with | T_map kv -> ok kv - | T_big_map kv -> ok kv | _ -> simple_fail "not a type map" +let get_t_big_map (t:type_value) = match t with + | T_big_map kv -> ok kv + | _ -> simple_fail "not a type big_map" + let get_t_list (t:type_value) = match t with | T_list t -> ok t | _ -> simple_fail "not a type list" diff --git a/src/mini_c/types.ml b/src/mini_c/types.ml index 8be621954..dba508062 100644 --- a/src/mini_c/types.ml +++ b/src/mini_c/types.ml @@ -48,6 +48,7 @@ type value = | D_some of value | D_none | D_map of (value * value) list + | D_big_map of (value * value) list | D_list of value list | D_set of value list (* | `Macro of anon_macro ... The future. *) diff --git a/src/operators/operators.ml b/src/operators/operators.ml index 3db1919f1..5989fed0f 100644 --- a/src/operators/operators.ml +++ b/src/operators/operators.ml @@ -235,53 +235,53 @@ module Typer = struct ok tl let map_remove : typer = typer_2 "MAP_REMOVE" @@ fun k m -> - let%bind (src , _) = get_t_map m in + let%bind (src , _) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src , k) in ok m let map_add : typer = typer_3 "MAP_ADD" @@ fun k v m -> - let%bind (src, dst) = get_t_map m in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src, k) in let%bind () = assert_type_value_eq (dst, v) in ok m let map_update : typer = typer_3 "MAP_UPDATE" @@ fun k v m -> - let%bind (src, dst) = get_t_map m in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src, k) in let%bind v' = get_t_option v in let%bind () = assert_type_value_eq (dst, v') in ok m let map_mem : typer = typer_2 "MAP_MEM" @@ fun k m -> - let%bind (src, _dst) = get_t_map m in + let%bind (src, _dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src, k) in ok @@ t_bool () let map_find : typer = typer_2 "MAP_FIND" @@ fun k m -> - let%bind (src, dst) = get_t_map m in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src, k) in ok @@ dst let map_find_opt : typer = typer_2 "MAP_FIND_OPT" @@ fun k m -> - let%bind (src, dst) = get_t_map m in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind () = assert_type_value_eq (src, k) in ok @@ t_option dst () let map_iter : typer = typer_2 "MAP_ITER" @@ fun m f -> - let%bind (k, v) = get_t_map_not_big_map m in + let%bind (k, v) = get_t_map m in let%bind (arg , res) = get_t_function f in let%bind () = assert_eq_1 arg (t_pair k v ()) in let%bind () = assert_eq_1 res (t_unit ()) in ok @@ t_unit () let map_map : typer = typer_2 "MAP_MAP" @@ fun m f -> - let%bind (k, v) = get_t_map_not_big_map m in + let%bind (k, v) = get_t_map m in let%bind (arg , res) = get_t_function f in let%bind () = assert_eq_1 arg (t_pair k v ()) in ok @@ t_map k res () let map_fold : typer = typer_2 "MAP_FOLD" @@ fun f m -> - let%bind (k, v) = get_t_map_not_big_map m in + let%bind (k, v) = get_t_map m in let%bind (arg_1 , res) = get_t_function f in let%bind (arg_2 , res') = get_t_function res in let%bind (arg_3 , res'') = get_t_function res' in @@ -293,7 +293,7 @@ module Typer = struct let size = typer_1 "SIZE" @@ fun t -> let%bind () = Assert.assert_true @@ - (is_t_map_not_big_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t) in + (is_t_map t || is_t_list t || is_t_string t || is_t_bytes t || is_t_set t ) in ok @@ t_nat () let slice = typer_3 "SLICE" @@ fun i j s -> @@ -312,7 +312,7 @@ module Typer = struct ok @@ t_unit () let get_force = typer_2 "MAP_GET_FORCE" @@ fun i m -> - let%bind (src, dst) = get_t_map m in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) m in let%bind _ = assert_type_value_eq (src, i) in ok dst @@ -641,6 +641,8 @@ module Compiler = struct ("MAP_GET_FORCE" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "GET_FORCE")]) ; ("MAP_FIND" , simple_binary @@ seq [prim I_GET ; i_assert_some_msg (i_push_string "MAP FIND")]) ; ("MAP_GET" , simple_binary @@ prim I_GET) ; + ("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]) ; + ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ; ("SIZE" , simple_unary @@ prim I_SIZE) ; ("FAILWITH" , simple_unary @@ prim I_FAILWITH) ; ("ASSERT_INFERRED" , simple_binary @@ i_if (seq [i_failwith]) (seq [i_drop ; i_push_unit])) ; @@ -655,8 +657,6 @@ module Compiler = struct ("CALL" , simple_ternary @@ prim I_TRANSFER_TOKENS) ; ("SOURCE" , simple_constant @@ prim I_SOURCE) ; ("SENDER" , simple_constant @@ prim I_SENDER) ; - ("MAP_ADD" , simple_ternary @@ seq [dip (i_some) ; prim I_UPDATE]) ; - ("MAP_UPDATE" , simple_ternary @@ prim I_UPDATE) ; ("SET_MEM" , simple_binary @@ prim I_MEM) ; ("SET_ADD" , simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_True)) ; prim I_UPDATE]) ; ("SET_REMOVE" , simple_binary @@ seq [dip (i_push (prim T_bool) (prim D_False)) ; prim I_UPDATE]) ; diff --git a/src/transpiler/transpiler.ml b/src/transpiler/transpiler.ml index 56da73d5e..ebd71877e 100644 --- a/src/transpiler/transpiler.ml +++ b/src/transpiler/transpiler.ml @@ -434,7 +434,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let%bind (init : expression) = return @@ E_make_empty_set t in bind_fold_list aux init lst' ) - | (E_map m | E_big_map m) -> ( + | E_map m -> ( let%bind (src, dst) = trace_strong (corner_case ~loc:__LOC__ "not a map") @@ Mini_c.Combinators.get_t_map tv in @@ -448,6 +448,20 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re let init = return @@ E_make_empty_map (src, dst) in List.fold_left aux init m ) + | E_big_map m -> ( + let%bind (src, dst) = + trace_strong (corner_case ~loc:__LOC__ "not a map") @@ + Mini_c.Combinators.get_t_big_map tv in + let aux : expression result -> (AST.ae * AST.ae) -> expression result = fun prev (k, v) -> + let%bind prev' = prev in + let%bind (k', v') = + let v' = e_a_some v ae.environment in + bind_map_pair (translate_annotated_expression) (k , v') in + return @@ E_constant ("UPDATE", [k' ; v' ; prev']) + in + let init = return @@ E_make_empty_map (src, dst) in + List.fold_left aux init m + ) | E_look_up dsi -> ( let%bind (ds', i') = bind_map_pair f dsi in return @@ E_constant ("MAP_GET", [i' ; ds']) @@ -800,8 +814,8 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression ) | T_constant ("big_map", [k_ty;v_ty]) -> ( let%bind lst = - trace_strong (wrong_mini_c_value "map" v) @@ - get_map v in + trace_strong (wrong_mini_c_value "big_map" v) @@ + get_big_map v in let%bind lst' = let aux = fun (k, v) -> let%bind k' = untranspile k k_ty in diff --git a/src/typer/typer.ml b/src/typer/typer.ml index c95ec44fb..5122e86aa 100644 --- a/src/typer/typer.ml +++ b/src/typer/typer.ml @@ -451,7 +451,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a ) | Access_map ae' -> ( let%bind ae'' = type_expression e ae' in - let%bind (k , v) = get_t_map prev.type_annotation in + let%bind (k , v) = bind_map_or (get_t_map , get_t_big_map) prev.type_annotation in let%bind () = Ast_typed.assert_type_value_eq (k , get_type_annotation ae'') in return (E_look_up (prev , ae'')) v @@ -570,7 +570,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a bind_fold_list aux None @@ List.map get_type_annotation @@ List.map fst lst' in - let%bind annot = bind_map_option get_t_map_key tv_opt in + let%bind annot = bind_map_option get_t_big_map_key tv_opt in trace (simple_info "empty map expression without a type annotation") @@ O.merge_annotation annot sub (needs_annotation ae "this map literal") in @@ -579,7 +579,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a bind_fold_list aux None @@ List.map get_type_annotation @@ List.map snd lst' in - let%bind annot = bind_map_option get_t_map_value tv_opt in + let%bind annot = bind_map_option get_t_big_map_value tv_opt in trace (simple_info "empty map expression without a type annotation") @@ O.merge_annotation annot sub (needs_annotation ae "this map literal") in @@ -644,7 +644,7 @@ and type_expression : environment -> ?tv_opt:O.type_value -> I.expression -> O.a return (E_application (f' , arg)) tv | E_look_up dsi -> let%bind (ds, ind) = bind_map_pair (type_expression e) dsi in - let%bind (src, dst) = get_t_map ds.type_annotation in + let%bind (src, dst) = bind_map_or (get_t_map , get_t_big_map) ds.type_annotation in let%bind _ = O.assert_type_value_eq (ind.type_annotation, src) in return (E_look_up (ds , ind)) (t_option dst ()) (* Advanced *) From b653996aae53b36e272ecb89d41f2753532a0b8b Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 13 Sep 2019 20:30:09 +0200 Subject: [PATCH 09/13] Big_map support Add big_map case in the uncompiler which takes the original big_map and apply the returned diff Add input_to_value option which compiles input expressions to mini_c.values --- src/compiler/uncompiler.ml | 32 ++++++++++--- src/contracts/big_map.ligo | 28 +++++------- src/main/run_mini_c.ml | 4 +- src/main/run_simplified.ml | 4 +- src/main/run_typed.ml | 84 +++++++++++++++++++++++++++++++++-- src/test/integration_tests.ml | 31 ++----------- src/test/test_helpers.ml | 24 +++++----- 7 files changed, 140 insertions(+), 67 deletions(-) diff --git a/src/compiler/uncompiler.ml b/src/compiler/uncompiler.ml index c0f8aa16b..c114d901d 100644 --- a/src/compiler/uncompiler.ml +++ b/src/compiler/uncompiler.ml @@ -6,19 +6,19 @@ open Protocol open Script_typed_ir open Script_ir_translator -let rec translate_value (Ex_typed_value (ty, value)) : value result = +let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result = match (ty, value) with | Pair_t ((a_ty, _, _), (b_ty, _, _), _), (a, b) -> ( - let%bind a = translate_value @@ Ex_typed_value(a_ty, a) in - let%bind b = translate_value @@ Ex_typed_value(b_ty, b) in + let%bind a = translate_value ?bm_opt @@ Ex_typed_value(a_ty, a) in + let%bind b = translate_value ?bm_opt @@ Ex_typed_value(b_ty, b) in ok @@ D_pair(a, b) ) | Union_t ((a_ty, _), _, _), L a -> ( - let%bind a = translate_value @@ Ex_typed_value(a_ty, a) in + let%bind a = translate_value ?bm_opt @@ Ex_typed_value(a_ty, a) in ok @@ D_left a ) | Union_t (_, (b_ty, _), _), R b -> ( - let%bind b = translate_value @@ Ex_typed_value(b_ty, b) in + let%bind b = translate_value ?bm_opt @@ Ex_typed_value(b_ty, b) in ok @@ D_right b ) | (Int_t _), n -> @@ -71,6 +71,28 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result = bind_map_list aux lst in ok @@ D_map lst' + | (Big_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.diff [] in + List.rev lst in + let%bind original_big_map = + match bm_opt with + | Some (D_big_map l) -> ok @@ l + | _ -> fail @@ simple_error "Do not have access to the original big_map" in + let%bind lst' = + let aux orig (k, v) = + let%bind k' = translate_value (Ex_typed_value (k_ty, k)) in + let orig_rem = List.remove_assoc k' orig in + match v with + | Some vadd -> + let%bind v' = translate_value (Ex_typed_value (v_ty, vadd)) in + if (List.mem_assoc k' orig) then ok @@ (k', v')::orig_rem + else ok @@ (k', v')::orig + | None -> ok orig_rem in + bind_fold_list aux original_big_map lst in + ok @@ D_big_map lst' | (List_t (ty, _)), lst -> let%bind lst' = let aux = fun t -> translate_value (Ex_typed_value (ty, t)) in diff --git a/src/contracts/big_map.ligo b/src/contracts/big_map.ligo index 3e9bf7ef9..b5f6d44c5 100644 --- a/src/contracts/big_map.ligo +++ b/src/contracts/big_map.ligo @@ -1,4 +1,3 @@ -// type storage_ is big_map(int, int) type storage_ is big_map(int, int) * unit function main(const p : unit; const s : storage_) : list(operation) * storage_ is @@ -10,15 +9,6 @@ function main(const p : unit; const s : storage_) : list(operation) * storage_ i } with ((nil: list(operation)), s) - - -// type foobar is map(int, int) - -// const fb : foobar = map -// 23 -> 0 ; -// 42 -> 0 ; -// end - function set_ (var n : int ; var m : storage_) : storage_ is block { var tmp : big_map(int,int) := m.0 ; tmp[23] := n ; @@ -31,10 +21,6 @@ function rm (var m : storage_) : storage_ is block { m.0 := tmp; } with m -// not supported -// function size_ (const m : storage_) : nat is -// block {skip} with (size(m.0)) - function gf (const m : storage_) : int is begin skip end with get_force(23, m.0) function get (const m : storage_) : option(int) is @@ -42,7 +28,9 @@ function get (const m : storage_) : option(int) is skip end with m.0[42] -// const bm : storage_ = map +// the following is not supported (negative test cases): + +// const bm : storage_ = big_map // 144 -> 23 ; // 51 -> 23 ; // 42 -> 23 ; @@ -50,7 +38,15 @@ function get (const m : storage_) : option(int) is // 421 -> 23 ; // end -// not supported +// type foobar is big_map(int, int) +// const fb : foobar = big_map +// 23 -> 0 ; +// 42 -> 0 ; +// end + +// function size_ (const m : storage_) : nat is +// block {skip} with (size(m.0)) + // function iter_op (const m : storage_) : int is // var r : int := 0 ; // function aggregate (const i : int ; const j : int) : unit is block { r := r + i + j } with unit ; diff --git a/src/main/run_mini_c.ml b/src/main/run_mini_c.ml index d13b4cc54..6b2443c09 100644 --- a/src/main/run_mini_c.ml +++ b/src/main/run_mini_c.ml @@ -23,7 +23,7 @@ let run_aux ?options (program:compiled_program) (input_michelson:Michelson.t) : Memory_proto_alpha.interpret ?options descr (Item(input, Empty)) in ok (Ex_typed_value (output_ty, output)) -let run_entry ?(debug_michelson = false) ?options (entry:anon_function) ty (input:value) : value result = +let run_entry ?(debug_michelson = false) ?options ?bm_opt (entry:anon_function) ty (input:value) : value result = let%bind compiled = let error = let title () = "compile entry" in @@ -51,5 +51,5 @@ let run_entry ?(debug_michelson = false) ?options (entry:anon_function) ty (inpu Format.printf "Compiled Output: %a\n" Michelson.pp michelson_value ; ok () ) ; - let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in + let%bind (result : value) = Compiler.Uncompiler.translate_value ?bm_opt ex_ty_value in ok result diff --git a/src/main/run_simplified.ml b/src/main/run_simplified.ml index 4faf34aaf..eadc0846e 100644 --- a/src/main/run_simplified.ml +++ b/src/main/run_simplified.ml @@ -1,7 +1,7 @@ open Trace let run_simplityped - ?options + ?input_to_value ?options ?(debug_mini_c = false) ?(debug_michelson = false) (program : Ast_typed.program) (entry : string) (input : Ast_simplified.expression) : Ast_simplified.expression result = @@ -13,7 +13,7 @@ let run_simplityped in Typer.type_expression env input in let%bind typed_result = - Run_typed.run_typed ?options ~debug_mini_c ~debug_michelson entry program typed_input in + Run_typed.run_typed ?input_to_value ?options ~debug_mini_c ~debug_michelson entry program typed_input in let%bind annotated_result = Typer.untype_expression typed_result in ok annotated_result diff --git a/src/main/run_typed.ml b/src/main/run_typed.ml index fc136c63c..9c5157c27 100644 --- a/src/main/run_typed.ml +++ b/src/main/run_typed.ml @@ -30,8 +30,84 @@ let evaluate_typed Transpiler.untranspile result typed_main.type_annotation in ok typed_result +(* returns a big_map if any *) +let rec fetch_big_map (v: Mini_c.value) : Mini_c.value option = + match v with + | D_pair (l , r) -> + begin + match (fetch_big_map l) with + | Some _ as s -> s + | None -> fetch_big_map r + end + | D_big_map _ as bm -> Some bm + | _ -> let () = Printf.printf "lal\n" in None + +(* try to convert expression to a literal *) +let rec exp_to_value (exp: Mini_c.expression) : Mini_c.value result = + let open! Mini_c in + match exp.content with + | E_literal v -> ok @@ v + | E_constant ("map" , lst) -> + let aux el = + let%bind l = exp_to_value el in + match l with + | D_pair (a , b) -> ok @@ (a , b) + | _ -> fail @@ simple_error "??" in + let%bind lstl = bind_map_list aux lst in + ok @@ D_map lstl + | E_constant ("big_map" , lst) -> + let aux el = + let%bind l = exp_to_value el in + match l with + | D_pair (a , b) -> ok @@ (a , b) + | _ -> fail @@ simple_error "??" in + let%bind lstl = bind_map_list aux lst in + ok @@ D_big_map lstl + | E_constant ("PAIR" , fst::snd::[]) -> + let%bind fstl = exp_to_value fst in + let%bind sndl = exp_to_value snd in + ok @@ D_pair (fstl , sndl) + | E_constant ("UPDATE", _) -> + let rec handle_prev upd = + match upd.content with + | E_constant ("UPDATE" , [k;v;prev]) -> + begin + match v.content with + | E_constant ("SOME" , [i]) -> + let%bind kl = exp_to_value k in + let%bind il = exp_to_value i in + let%bind prevl = handle_prev prev in + ok @@ (kl,il)::prevl + | E_constant ("NONE" , []) -> + let%bind prevl = handle_prev prev in + ok @@ prevl + | _ -> failwith "UPDATE second parameter is not an option" + end + | E_make_empty_map _ -> + ok @@ [] + | _ -> failwith "impossible" + in + begin + match exp.type_value with + | T_big_map _ -> + let%bind kvl = handle_prev exp in + ok @@ D_big_map kvl + | T_map _ -> + let%bind kvl = handle_prev exp in + ok @@ D_map kvl + | _ -> failwith "UPDATE with a non-map type_value" + end + | _ -> + fail @@ simple_error "Can not convert expression to literal" + +let convert_to_literals (e:Ast_typed.annotated_expression) : Mini_c.value result = + let open Transpiler in + let%bind exp = translate_annotated_expression e in (*Mini_c.expression*) + let%bind value = exp_to_value exp in + ok @@ value + let run_typed - ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) + ?(input_to_value = false) ?(debug_mini_c = false) ?(debug_michelson = false) ?options (entry:string) (program:Ast_typed.program) (input:Ast_typed.annotated_expression) : Ast_typed.annotated_expression result = let%bind () = let open Ast_typed in @@ -49,7 +125,9 @@ let run_typed Format.(printf "Mini_c : %a\n%!" Mini_c.PP.function_ mini_c_main) ) ; - let%bind mini_c_value = transpile_value input in + let%bind mini_c_value = if input_to_value then + convert_to_literals input else transpile_value input in + let bm_opt = if input_to_value then fetch_big_map mini_c_value else None in let%bind mini_c_result = let error = @@ -59,7 +137,7 @@ let run_typed in error title content in trace error @@ - Run_mini_c.run_entry ~debug_michelson ?options mini_c_main ty mini_c_value in + Run_mini_c.run_entry ~debug_michelson ?options ?bm_opt mini_c_main ty mini_c_value in let%bind typed_result = let%bind main_result_type = let%bind typed_main = Ast_typed.get_functional_entry program entry in diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index c08a18d55..b6122fa1b 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -402,16 +402,7 @@ let big_map () : unit result = let%bind () = let make_input = fun n -> ez [(23, n) ; (42, 4)] in let make_expected = e_int in - expect_eq_n program "gf" make_input make_expected - in - (* let%bind () = - let make_input = fun n -> ez List.(map (fun x -> (x, x)) @@ range n) in - let make_expected = e_nat in - expect_eq_n_strict_pos_small program "size_" make_input make_expected - in - let%bind () = - let expected = ez [(23, 0) ; (42, 0)] in - expect_eq_evaluate program "fb" expected + expect_eq_n ?input_to_value:(Some true) program "gf" make_input make_expected in let%bind () = let make_input = fun n -> @@ -419,32 +410,18 @@ let big_map () : unit result = e_tuple [(e_int n) ; m] in let make_expected = fun n -> ez [(23 , n) ; (42 , 0)] in - expect_eq_n_pos_small program "set_" make_input make_expected + expect_eq_n_pos_small ?input_to_value:(Some true) program "set_" make_input make_expected in let%bind () = let make_input = fun n -> ez [(23, n) ; (42, 4)] in let make_expected = fun _ -> e_some @@ e_int 4 in - expect_eq_n program "get" make_input make_expected - in - let%bind () = - let expected = ez @@ List.map (fun x -> (x, 23)) [144 ; 51 ; 42 ; 120 ; 421] in - expect_eq_evaluate program "bm" expected + expect_eq_n ?input_to_value:(Some true) program "get" make_input make_expected in let%bind () = let input = ez [(23, 23) ; (42, 42)] in let expected = ez [23, 23] in - expect_eq program "rm" input expected - in *) - (* let%bind () = - let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in - let expected = e_int 66 in - expect_eq program "iter_op" input expected + expect_eq ?input_to_value:(Some true) program "rm" input expected in - let%bind () = - let input = ez [(1 , 10) ; (2 , 20) ; (3 , 30) ] in - let expected = ez [(1 , 11) ; (2 , 21) ; (3 , 31) ] in - expect_eq program "map_op" input expected - in *) ok () let list () : unit result = diff --git a/src/test/test_helpers.ml b/src/test/test_helpers.ml index f1a51a794..90b412c2e 100644 --- a/src/test/test_helpers.ml +++ b/src/test/test_helpers.ml @@ -31,14 +31,14 @@ let test_suite name lst = Test_suite (name , lst) open Ast_simplified.Combinators -let expect ?options program entry_point input expecter = +let expect ?input_to_value ?options program entry_point input expecter = let%bind result = let run_error = let title () = "expect run" in let content () = Format.asprintf "Entry_point: %s" entry_point in error title content in trace run_error @@ - Ligo.Run.run_simplityped ~debug_michelson:true ?options program entry_point input in + Ligo.Run.run_simplityped ?input_to_value ~debug_michelson:true ?options program entry_point input in expecter result let expect_fail ?options program entry_point input = @@ -52,7 +52,7 @@ let expect_fail ?options program entry_point input = @@ Ligo.Run.run_simplityped ~debug_michelson:true ?options program entry_point input -let expect_eq ?options program entry_point input expected = +let expect_eq ?input_to_value ?options program entry_point input expected = let expecter = fun result -> let expect_error = let title () = "expect result" in @@ -62,7 +62,7 @@ let expect_eq ?options program entry_point input expected = error title content in trace expect_error @@ Ast_simplified.Misc.assert_value_eq (expected , result) in - expect ?options program entry_point input expecter + expect ?input_to_value ?options program entry_point input expecter let expect_evaluate program entry_point expecter = let error = @@ -89,23 +89,23 @@ let expect_n_aux ?options lst program entry_point make_input make_expecter = let%bind _ = bind_map_list aux lst in ok () -let expect_eq_n_aux ?options lst program entry_point make_input make_expected = +let expect_eq_n_aux ?input_to_value ?options lst program entry_point make_input make_expected = let aux n = let input = make_input n in let expected = make_expected n in trace (simple_error ("expect_eq_n " ^ (string_of_int n))) @@ - let result = expect_eq ?options program entry_point input expected in + let result = expect_eq ?input_to_value ?options program entry_point input expected in result in let%bind _ = bind_map_list_seq aux lst in ok () -let expect_eq_n ?options = expect_eq_n_aux ?options [0 ; 1 ; 2 ; 42 ; 163 ; -1] -let expect_eq_n_pos ?options = expect_eq_n_aux ?options [0 ; 1 ; 2 ; 42 ; 163] -let expect_eq_n_strict_pos ?options = expect_eq_n_aux ?options [2 ; 42 ; 163] -let expect_eq_n_pos_small ?options = expect_eq_n_aux ?options [0 ; 1 ; 2 ; 10] -let expect_eq_n_strict_pos_small ?options = expect_eq_n_aux ?options [1 ; 2 ; 10] -let expect_eq_n_pos_mid = expect_eq_n_aux [0 ; 1 ; 2 ; 10 ; 33] +let expect_eq_n ?input_to_value ?options = expect_eq_n_aux ?input_to_value ?options [0 ; 1 ; 2 ; 42 ; 163 ; -1] +let expect_eq_n_pos ?input_to_value ?options = expect_eq_n_aux ?input_to_value ?options [0 ; 1 ; 2 ; 42 ; 163] +let expect_eq_n_strict_pos ?input_to_value ?options = expect_eq_n_aux ?input_to_value ?options [2 ; 42 ; 163] +let expect_eq_n_pos_small ?input_to_value ?options = expect_eq_n_aux ?input_to_value ?options [0 ; 1 ; 2 ; 10] +let expect_eq_n_strict_pos_small ?input_to_value ?options = expect_eq_n_aux ?input_to_value ?options [1 ; 2 ; 10] +let expect_eq_n_pos_mid ?input_to_value = expect_eq_n_aux ?input_to_value [0 ; 1 ; 2 ; 10 ; 33] let expect_n_pos_small ?options = expect_n_aux ?options [0 ; 2 ; 10] let expect_n_strict_pos_small ?options = expect_n_aux ?options [2 ; 10] From ea6f51bd55c34a19f829daa5671e2962fdc29bf7 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Tue, 17 Sep 2019 18:17:12 +0200 Subject: [PATCH 10/13] CLI checked, compile-storage and dry-run Add a '--bigmap' option to the CLI. This way all the maps in the AST are transformed to bigmaps --- src/bin/cli.ml | 20 ++++++++++++++------ src/contracts/big_map.ligo | 1 + src/main/run_source.ml | 33 +++++++++++++++++++++++++++++---- src/main/run_typed.ml | 5 +++-- 4 files changed, 47 insertions(+), 12 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 11777b504..fd3fa05be 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -37,6 +37,14 @@ let syntax = info ~docv ~doc ["syntax" ; "s"] in value @@ opt string "auto" info +let bigmap = + let open Arg in + let info = + let docv = "BIGMAP" in + let doc = "$(docv) is necessary when your storage embeds a big_map." in + info ~docv ~doc ["bigmap"] in + value @@ flag info + let amount = let open Arg in let info = @@ -76,30 +84,30 @@ let compile_parameter = (term , Term.info ~docs cmdname) let compile_storage = - let f source entry_point expression syntax = + let f source entry_point expression syntax bigmap = toplevel @@ let%bind value = trace (simple_error "compile-storage") @@ - Ligo.Run.compile_contract_storage source entry_point expression (Syntax_name syntax) in + Ligo.Run.compile_contract_storage ?bigmap:(Some bigmap) source entry_point expression (Syntax_name syntax) in Format.printf "%s\n" value; ok () in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "STORAGE" 2 $ syntax $ bigmap) in let cmdname = "compile-storage" in let docs = "Subcommand: compile an initial storage in ligo syntax to a michelson expression. The resulting michelson expression can be passed as an argument in a transaction which originates a contract. See `ligo " ^ cmdname ^ " --help' for a list of options specific to this subcommand." in (term , Term.info ~docs cmdname) let dry_run = - let f source entry_point storage input amount syntax = + let f source entry_point storage input bigmap amount syntax = toplevel @@ let%bind output = - Ligo.Run.run_contract ~amount source entry_point storage input (Syntax_name syntax) in + Ligo.Run.run_contract ~bigmap ~amount source entry_point storage input (Syntax_name syntax) in Format.printf "%a\n" Ast_simplified.PP.expression output ; ok () in let term = - Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ amount $ syntax) in + Term.(const f $ source 0 $ entry_point 1 $ expression "PARAMETER" 2 $ expression "STORAGE" 3 $ bigmap $ amount $ syntax) in let cmdname = "dry-run" in let docs = "Subcommand: run a smart-contract with the given storage and input." in (term , Term.info ~docs cmdname) diff --git a/src/contracts/big_map.ligo b/src/contracts/big_map.ligo index b5f6d44c5..461c2c206 100644 --- a/src/contracts/big_map.ligo +++ b/src/contracts/big_map.ligo @@ -5,6 +5,7 @@ function main(const p : unit; const s : storage_) : list(operation) * storage_ i var toto : option (int) := Some(0); block { toto := r[23]; + r[2] := 444; s.0 := r; } with ((nil: list(operation)), s) diff --git a/src/main/run_source.ml b/src/main/run_source.ml index 10904914a..71f7d3b55 100644 --- a/src/main/run_source.ml +++ b/src/main/run_source.ml @@ -46,6 +46,17 @@ include struct ok () end +let transpile_value_literals + (e:Ast_typed.annotated_expression) : (Mini_c.value * _) result = + let%bind (_ , ty) = + let open Transpiler in + let (f , _) = functionalize e in + let%bind main = translate_main f e.location in + ok main + in + let%bind lit = Run_typed.convert_to_literals e in + ok (lit , snd ty) + let transpile_value (e:Ast_typed.annotated_expression) : (Mini_c.value * _) result = let%bind (f , ty) = @@ -196,8 +207,20 @@ let compile_contract_parameter : string -> string -> string -> s_syntax -> strin in ok expr +(* Replace occurrences of E_map with E_big_map in the AST *) +let rec transform_map_to_big_map (e: Ast_simplified.expression) : Ast_simplified.expression result = + let open Ast_simplified in + match e.wrap_content with + | E_tuple [fst;snd] -> + let%bind tr_fst = transform_map_to_big_map fst in + let new_tuple = Location.wrap (E_tuple [tr_fst;snd]) in + ok @@ new_tuple + | E_map lst -> + let tr_map = Location.wrap (E_big_map lst) in + ok @@ tr_map + | _ -> fail @@ simple_error "can not replace map with big_map" -let compile_contract_storage : string -> string -> string -> s_syntax -> string result = fun source_filename entry_point expression syntax -> +let compile_contract_storage ?(bigmap = false) source_filename entry_point expression syntax : string result = let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind (program , storage_tv) = let%bind simplified = parsify syntax source_filename in @@ -212,6 +235,7 @@ let compile_contract_storage : string -> string -> string -> s_syntax -> string in let%bind expr = let%bind simplified = parsify_expression syntax expression in + let%bind simplified = if bigmap then transform_map_to_big_map simplified else ok @@ simplified in let%bind typed = let env = let last_declaration = Location.unwrap List.(hd @@ rev program) in @@ -225,7 +249,7 @@ let compile_contract_storage : string -> string -> string -> s_syntax -> string Ast_typed.assert_type_value_eq (storage_tv , typed.type_annotation) in let%bind (mini_c , mini_c_ty) = trace (simple_error "transpiling expression") @@ - transpile_value typed in + (if bigmap then transpile_value_literals typed else transpile_value typed) in let%bind michelson = trace (simple_error "compiling expression") @@ Compiler.translate_value mini_c mini_c_ty in @@ -249,7 +273,7 @@ let type_file ?(debug_simplify = false) ?(debug_typed = false) )) ; ok typed -let run_contract ?amount source_filename entry_point storage input syntax = +let run_contract ?(bigmap = false) ?amount source_filename entry_point storage input syntax = let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind typed = type_file syntax source_filename in @@ -257,11 +281,12 @@ let run_contract ?amount source_filename entry_point storage input syntax = parsify_expression syntax storage in let%bind input_simpl = parsify_expression syntax input in + let%bind input_simpl = if bigmap then transform_map_to_big_map input_simpl else ok @@ input_simpl in let options = let open Proto_alpha_utils.Memory_proto_alpha in let amount = Option.bind (fun amount -> Protocol.Alpha_context.Tez.of_string amount) amount in (make_options ?amount ()) in - Run_simplified.run_simplityped ~options typed entry_point (Ast_simplified.e_pair storage_simpl input_simpl) + Run_simplified.run_simplityped ?input_to_value:(Some bigmap) ~options typed entry_point (Ast_simplified.e_pair storage_simpl input_simpl) let run_function ?amount source_filename entry_point parameter syntax = let%bind syntax = syntax_to_variant syntax (Some source_filename) in diff --git a/src/main/run_typed.ml b/src/main/run_typed.ml index 9c5157c27..aef51cd56 100644 --- a/src/main/run_typed.ml +++ b/src/main/run_typed.ml @@ -30,7 +30,7 @@ let evaluate_typed Transpiler.untranspile result typed_main.type_annotation in ok typed_result -(* returns a big_map if any *) +(* returns a big_map if any. used to reconstruct the map from the diff when uncompiling *) let rec fetch_big_map (v: Mini_c.value) : Mini_c.value option = match v with | D_pair (l , r) -> @@ -40,7 +40,7 @@ let rec fetch_big_map (v: Mini_c.value) : Mini_c.value option = | None -> fetch_big_map r end | D_big_map _ as bm -> Some bm - | _ -> let () = Printf.printf "lal\n" in None + | _ -> None (* try to convert expression to a literal *) let rec exp_to_value (exp: Mini_c.expression) : Mini_c.value result = @@ -67,6 +67,7 @@ let rec exp_to_value (exp: Mini_c.expression) : Mini_c.value result = let%bind fstl = exp_to_value fst in let%bind sndl = exp_to_value snd in ok @@ D_pair (fstl , sndl) + | E_constant ("UNIT", _) -> ok @@ D_unit | E_constant ("UPDATE", _) -> let rec handle_prev upd = match upd.content with From 8978c5c4d79bd86347a3cd56b65e436318445c39 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Fri, 20 Sep 2019 21:26:34 +0200 Subject: [PATCH 11/13] Print expresion in error message to ease further debugging --- src/main/run_typed.ml | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/main/run_typed.ml b/src/main/run_typed.ml index aef51cd56..15478a9d9 100644 --- a/src/main/run_typed.ml +++ b/src/main/run_typed.ml @@ -86,7 +86,7 @@ let rec exp_to_value (exp: Mini_c.expression) : Mini_c.value result = end | E_make_empty_map _ -> ok @@ [] - | _ -> failwith "impossible" + | _ -> failwith "Ill-constructed map" in begin match exp.type_value with @@ -98,8 +98,9 @@ let rec exp_to_value (exp: Mini_c.expression) : Mini_c.value result = ok @@ D_map kvl | _ -> failwith "UPDATE with a non-map type_value" end - | _ -> - fail @@ simple_error "Can not convert expression to literal" + | _ as nl -> + let expp = Format.asprintf "'%a'" Mini_c.PP.expression' nl in + fail @@ simple_error ("Can not convert expression "^expp^" to literal") let convert_to_literals (e:Ast_typed.annotated_expression) : Mini_c.value result = let open Transpiler in From 37836f9512ebc630cd869c66f9ae8a8388a233e4 Mon Sep 17 00:00:00 2001 From: galfour Date: Sun, 22 Sep 2019 22:44:50 +0200 Subject: [PATCH 12/13] adding option --- src/main/compile/of_simplified.ml | 4 ++-- src/main/compile/of_typed.ml | 3 ++- src/main/run/of_simplified.ml | 4 ++-- src/{ => test}/contracts/big_map.ligo | 0 4 files changed, 6 insertions(+), 5 deletions(-) rename src/{ => test}/contracts/big_map.ligo (100%) diff --git a/src/main/compile/of_simplified.ml b/src/main/compile/of_simplified.ml index fa27f3d6e..215c908a5 100644 --- a/src/main/compile/of_simplified.ml +++ b/src/main/compile/of_simplified.ml @@ -14,9 +14,9 @@ let compile_expression_as_function_entry (program : program) entry_point : _ res let%bind typed_program = Typer.type_program program in Of_typed.compile_expression_as_function_entry typed_program entry_point -let compile_expression ?(env = Ast_typed.Environment.full_empty) ae : Michelson.t result = +let compile_expression ?(env = Ast_typed.Environment.full_empty) ?value ae : Michelson.t result = let%bind typed = Typer.type_expression env ae in - Of_typed.compile_expression typed + Of_typed.compile_expression ?value typed let uncompile_typed_program_entry_expression_result program entry ex_ty_value = let%bind output_type = diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index e6a33abd7..ea75960b9 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -3,7 +3,8 @@ open Ast_typed open Tezos_utils -let compile_expression : annotated_expression -> Michelson.t result = fun e -> +let compile_expression ?(value = false) : annotated_expression -> Michelson.t result = fun e -> + let _ = value in let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in let%bind expr = Of_mini_c.compile_expression mini_c_expression in ok expr diff --git a/src/main/run/of_simplified.ml b/src/main/run/of_simplified.ml index 4332ca9e5..e0e3e1a17 100644 --- a/src/main/run/of_simplified.ml +++ b/src/main/run/of_simplified.ml @@ -7,13 +7,13 @@ let get_final_environment program = post_env let run_typed_program - ?options + ?options ?input_to_value (program : Ast_typed.program) (entry : string) (input : expression) : expression result = let%bind code = Compile.Of_typed.compile_function_entry program entry in let%bind input = let env = get_final_environment program in - Compile.Of_simplified.compile_expression ~env input + Compile.Of_simplified.compile_expression ~env ?value:input_to_value input in let%bind ex_ty_value = Of_michelson.run ?options code input in Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry ex_ty_value diff --git a/src/contracts/big_map.ligo b/src/test/contracts/big_map.ligo similarity index 100% rename from src/contracts/big_map.ligo rename to src/test/contracts/big_map.ligo From 96fd0b4660125659d5e13954bd76409d5293c4a7 Mon Sep 17 00:00:00 2001 From: galfour Date: Sun, 22 Sep 2019 23:39:15 +0200 Subject: [PATCH 13/13] yay --- src/bin/cli.ml | 4 +- src/main/compile/of_mini_c.ml | 12 +++++- src/main/compile/of_source.ml | 8 ++-- src/main/compile/of_typed.ml | 3 +- src/main/run/of_simplified.ml | 2 +- src/main/run/of_source.ml | 4 +- src/passes/8-compiler/uncompiler.ml | 6 ++- src/stages/mini_c/misc.ml | 58 +++++++++++++++++++++++++++++ src/test/integration_tests.ml | 2 +- 9 files changed, 83 insertions(+), 16 deletions(-) diff --git a/src/bin/cli.ml b/src/bin/cli.ml index 47aac3cd9..3ca3d2bf3 100644 --- a/src/bin/cli.ml +++ b/src/bin/cli.ml @@ -103,7 +103,7 @@ let compile_storage = toplevel ~display_format @@ let%bind value = trace (simple_error "compile-storage") @@ - Ligo.Compile.Of_source.compile_file_contract_storage ~bigmap source entry_point expression (Syntax_name syntax) in + Ligo.Compile.Of_source.compile_file_contract_storage ~value:bigmap source entry_point expression (Syntax_name syntax) in ok @@ Format.asprintf "%a\n" Tezos_utils.Michelson.pp value in let term = @@ -116,7 +116,7 @@ let dry_run = let f source entry_point storage input amount syntax display_format bigmap = toplevel ~display_format @@ let%bind output = - Ligo.Run.Of_source.run_contract ~amount ~bigmap source entry_point storage input (Syntax_name syntax) in + Ligo.Run.Of_source.run_contract ~amount ~storage_value:bigmap source entry_point storage input (Syntax_name syntax) in ok @@ Format.asprintf "%a\n" Ast_simplified.PP.expression output in let term = diff --git a/src/main/compile/of_mini_c.ml b/src/main/compile/of_mini_c.ml index 5a1ff886e..34d8cd753 100644 --- a/src/main/compile/of_mini_c.ml +++ b/src/main/compile/of_mini_c.ml @@ -5,8 +5,16 @@ open Tezos_utils let compile_value : value -> type_value -> Michelson.t result = Compiler.Program.translate_value -let compile_expression : expression -> _ result = fun e -> - Compiler.Program.translate_expression e Compiler.Environment.empty +let compile_expression ?(value = false) : expression -> _ result = fun e -> + if value then ( + let%bind value = expression_to_value e in + Format.printf "Compile to value\n" ; + let%bind result = compile_value value e.type_value in + Format.printf "Compiled to value\n" ; + ok result + ) else ( + Compiler.Program.translate_expression e Compiler.Environment.empty + ) let compile_expression_as_function : expression -> _ result = fun e -> let (input , output) = t_unit , e.type_value in diff --git a/src/main/compile/of_source.ml b/src/main/compile/of_source.ml index 169dba0da..42c6adf91 100644 --- a/src/main/compile/of_source.ml +++ b/src/main/compile/of_source.ml @@ -30,19 +30,19 @@ let compile_file_expression : string -> string -> string -> s_syntax -> Michelso let%bind simplified = parsify_expression syntax expression in Of_simplified.compile_expression simplified -let compile_file_contract_storage : string -> string -> string -> s_syntax -> Michelson.t result = +let compile_file_contract_storage ~value : string -> string -> string -> s_syntax -> Michelson.t result = fun source_filename _entry_point expression syntax -> let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind simplified = parsify_expression syntax expression in - Of_simplified.compile_expression simplified + Of_simplified.compile_expression ~value simplified let compile_file_contract_args = - fun source_filename _entry_point storage parameter syntax -> + fun ?value source_filename _entry_point storage parameter syntax -> let%bind syntax = syntax_to_variant syntax (Some source_filename) in let%bind storage_simplified = parsify_expression syntax storage in let%bind parameter_simplified = parsify_expression syntax parameter in let args = Ast_simplified.e_pair storage_simplified parameter_simplified in - Of_simplified.compile_expression args + Of_simplified.compile_expression ?value args let type_file ?(debug_simplify = false) ?(debug_typed = false) syntax (source_filename:string) : Ast_typed.program result = diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index ea75960b9..e8ac1e8e7 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -4,9 +4,8 @@ open Tezos_utils let compile_expression ?(value = false) : annotated_expression -> Michelson.t result = fun e -> - let _ = value in let%bind mini_c_expression = Transpiler.transpile_annotated_expression e in - let%bind expr = Of_mini_c.compile_expression mini_c_expression in + let%bind expr = Of_mini_c.compile_expression ~value mini_c_expression in ok expr let compile_expression_as_function : annotated_expression -> _ result = fun e -> diff --git a/src/main/run/of_simplified.ml b/src/main/run/of_simplified.ml index e0e3e1a17..9c5d830cc 100644 --- a/src/main/run/of_simplified.ml +++ b/src/main/run/of_simplified.ml @@ -15,7 +15,7 @@ let run_typed_program let env = get_final_environment program in Compile.Of_simplified.compile_expression ~env ?value:input_to_value input in - let%bind ex_ty_value = Of_michelson.run ?options code input in + let%bind ex_ty_value = Of_michelson.run ?is_input_value:input_to_value ?options code input in Compile.Of_simplified.uncompile_typed_program_entry_function_result program entry ex_ty_value let evaluate_typed_program_entry diff --git a/src/main/run/of_source.ml b/src/main/run/of_source.ml index 5bc8b421c..3014cbbb7 100644 --- a/src/main/run/of_source.ml +++ b/src/main/run/of_source.ml @@ -46,10 +46,10 @@ include struct ok () end -let run_contract ?amount source_filename entry_point storage parameter syntax = +let run_contract ?amount ?storage_value source_filename entry_point storage parameter syntax = let%bind program = Compile.Of_source.type_file syntax source_filename in let%bind code = Compile.Of_typed.compile_function_entry program entry_point in - let%bind args = Compile.Of_source.compile_file_contract_args source_filename entry_point storage parameter syntax in + let%bind args = Compile.Of_source.compile_file_contract_args ?value:storage_value source_filename entry_point storage parameter syntax in let%bind ex_value_ty = let options = let open Proto_alpha_utils.Memory_proto_alpha in diff --git a/src/passes/8-compiler/uncompiler.ml b/src/passes/8-compiler/uncompiler.ml index c114d901d..2838298d3 100644 --- a/src/passes/8-compiler/uncompiler.ml +++ b/src/passes/8-compiler/uncompiler.ml @@ -77,10 +77,12 @@ let rec translate_value ?bm_opt (Ex_typed_value (ty, value)) : value result = let aux k v acc = (k, v) :: acc in let lst = Script_ir_translator.map_fold aux m.diff [] in List.rev lst in - let%bind original_big_map = + let%bind original_big_map = match bm_opt with | Some (D_big_map l) -> ok @@ l - | _ -> fail @@ simple_error "Do not have access to the original big_map" in + | _ -> ok [] + (* | _ -> fail @@ simple_error "Do not have access to the original big_map" . When does this matter? *) + in let%bind lst' = let aux orig (k, v) = let%bind k' = translate_value (Ex_typed_value (k_ty, k)) in diff --git a/src/stages/mini_c/misc.ml b/src/stages/mini_c/misc.ml index 21e049e38..60810643c 100644 --- a/src/stages/mini_c/misc.ml +++ b/src/stages/mini_c/misc.ml @@ -106,3 +106,61 @@ let aggregate_entry (lst : program) (name : string) (to_functionalize : bool) : Format.printf "Not functional: %a\n" PP.expression entry_expression ; fail @@ Errors.not_functional_main name ) + +let rec expression_to_value (exp: expression) : value result = + match exp.content with + | E_literal v -> ok @@ v + | E_constant ("map" , lst) -> + let aux el = + let%bind l = expression_to_value el in + match l with + | D_pair (a , b) -> ok @@ (a , b) + | _ -> fail @@ simple_error "??" in + let%bind lstl = bind_map_list aux lst in + ok @@ D_map lstl + | E_constant ("big_map" , lst) -> + let aux el = + let%bind l = expression_to_value el in + match l with + | D_pair (a , b) -> ok @@ (a , b) + | _ -> fail @@ simple_error "??" in + let%bind lstl = bind_map_list aux lst in + ok @@ D_big_map lstl + | E_constant ("PAIR" , fst::snd::[]) -> + let%bind fstl = expression_to_value fst in + let%bind sndl = expression_to_value snd in + ok @@ D_pair (fstl , sndl) + | E_constant ("UNIT", _) -> ok @@ D_unit + | E_constant ("UPDATE", _) -> + let rec handle_prev upd = + match upd.content with + | E_constant ("UPDATE" , [k;v;prev]) -> + begin + match v.content with + | E_constant ("SOME" , [i]) -> + let%bind kl = expression_to_value k in + let%bind il = expression_to_value i in + let%bind prevl = handle_prev prev in + ok @@ (kl,il)::prevl + | E_constant ("NONE" , []) -> + let%bind prevl = handle_prev prev in + ok @@ prevl + | _ -> failwith "UPDATE second parameter is not an option" + end + | E_make_empty_map _ -> + ok @@ [] + | _ -> failwith "Ill-constructed map" + in + begin + match exp.type_value with + | T_big_map _ -> + let%bind kvl = handle_prev exp in + ok @@ D_big_map kvl + | T_map _ -> + let%bind kvl = handle_prev exp in + ok @@ D_map kvl + | _ -> failwith "UPDATE with a non-map type_value" + end + | _ as nl -> + let expp = Format.asprintf "'%a'" PP.expression' nl in + fail @@ simple_error ("Can not convert expression "^expp^" to literal") diff --git a/src/test/integration_tests.ml b/src/test/integration_tests.ml index f3f49af85..639310afc 100644 --- a/src/test/integration_tests.ml +++ b/src/test/integration_tests.ml @@ -417,7 +417,7 @@ let big_map () : unit result = let%bind () = let make_input = fun n -> ez [(23, n) ; (42, 4)] in let make_expected = e_int in - expect_eq_n ?input_to_value:(Some true) program "gf" make_input make_expected + expect_eq_n ~input_to_value:true program "gf" make_input make_expected in let%bind () = let make_input = fun n ->