balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Bla

Browse Source
This commit is contained in:
Lesenechal Remi 2019-09-11 16:02:06 +02:00
parent c7cfce2bf7
commit 304184bcd3
8 changed files with 69 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
src/ast_typed/combinators.ml
View File

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

11
src/compiler/compiler_program.ml
View File

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

1
src/mini_c/PP.ml
View File

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

9
src/mini_c/combinators.ml
View File

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

1
src/mini_c/types.ml
View File

@ -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. *)

26
src/operators/operators.ml
View File

@ -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]) ;

20
src/transpiler/transpiler.ml
View File

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

8
src/typer/typer.ml
View File

@ -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 *)