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

add set tests

Browse Source
This commit is contained in:
galfour 2019-07-19 14:35:47 +02:00
parent 5c3d801c78
commit 33101820ec
9 changed files with 104 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
src/compiler/compiler_program.ml
View File

@ -26,6 +26,11 @@ let get_predicate : string -> type_value -> expression list -> predicate result
let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_unary @@ prim ~children:[m_ty] I_NIL
)
| "SET_EMPTY" -> (
let%bind ty' = Mini_c.get_t_set ty in
let%bind m_ty = Compiler_type.type_ ty' in
ok @@ simple_constant @@ prim ~children:[m_ty] I_EMPTY_SET
)
| "UNPACK" -> (
let%bind ty' = Mini_c.get_t_option ty in
let%bind m_ty = Compiler_type.type_ ty' in
@ -86,14 +91,16 @@ let rec translate_value (v:value) : michelson result = match v with
ok @@ prim ~children:[s'] D_Some
| D_map lst ->
let%bind lst' = bind_map_list (bind_map_pair translate_value) 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 lst'
ok @@ seq @@ List.map aux sorted
| D_list lst ->
let%bind lst' = bind_map_list translate_value lst in
ok @@ seq lst'
| D_set lst ->
let%bind lst' = bind_map_list translate_value lst in
ok @@ seq lst'
let sorted = List.sort compare lst' in
ok @@ seq sorted
| D_operation _ ->
simple_fail "can't compile an operation"

15
src/contracts/set_arithmetic.ligo Normal file
View File

@ -0,0 +1,15 @@
const s_e : set(string) = (set_empty : set(string))
const s_fb : set(string) = set [
"foo" ;
"bar" ;
]
function add_op (const s : set(string)) : set(string) is
begin skip end with set_add("foobar" , s)
function remove_op (const s : set(string)) : set(string) is
begin skip end with set_remove("foobar" , s)
function mem_op (const s : set(string)) : bool is
begin skip end with set_mem("foobar" , s)

8
src/main/run_mini_c.ml
View File

@ -32,8 +32,14 @@ let run_entry ?(debug_michelson = false) ?options (entry:anon_function) (input:v
error title content in
trace error @@
translate_entry entry in
if debug_michelson then Format.printf "Program: %a\n" Michelson.pp compiled.body ;
let%bind input_michelson = translate_value input in
if debug_michelson then (
Format.printf "Program: %a\n" Michelson.pp compiled.body ;
Format.printf "Expression: %a\n" PP.expression entry.result ;
Format.printf "Input: %a\n" PP.value input ;
Format.printf "Input Type: %a\n" PP.type_ entry.input ;
Format.printf "Compiled Input: %a\n" Michelson.pp input_michelson ;
) ;
let%bind ex_ty_value = run_aux ?options compiled input_michelson in
let%bind (result : value) = Compiler.Uncompiler.translate_value ex_ty_value in
ok result

12
src/operators/operators.ml
View File

@ -74,6 +74,11 @@ module Simplify = struct
("bitwise_xor" , "XOR") ;
("string_concat" , "CONCAT") ;
("string_slice" , "SLICE") ;
("set_empty" , "SET_EMPTY") ;
("set_mem" , "SET_MEM") ;
("set_add" , "SET_ADD") ;
("set_remove" , "SET_REMOVE") ;
("set_iter" , "SET_ITER") ;
]
let type_constants = type_constants
@ -194,6 +199,11 @@ module Typer = struct
| None -> simple_fail "untyped NONE"
| Some t -> ok t
let set_empty = typer_0 "SET_EMPTY" @@ fun tv_opt ->
match tv_opt with
| None -> simple_fail "untyped SET_EMPTY"
| Some t -> ok t
let sub = typer_2 "SUB" @@ fun a b ->
if (eq_2 (a , b) (t_int ()))
then ok @@ t_int () else
@ -571,6 +581,7 @@ module Typer = struct
map_map ;
map_fold ;
map_iter ;
set_empty ;
set_mem ;
set_add ;
set_remove ;
@ -662,6 +673,7 @@ module Compiler = struct
("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]) ;
("SLICE" , simple_ternary @@ seq [prim I_SLICE ; i_assert_some_msg (i_push_string "SLICE")]) ;
("SHA256" , simple_unary @@ prim I_SHA256) ;
("SHA512" , simple_unary @@ prim I_SHA512) ;

17
src/simplify/pascaligo.ml
View File

@ -484,7 +484,7 @@ let rec simpl_expression (t:Raw.expr) : expr result =
fail @@ unsupported_string_catenation e
| ELogic l -> simpl_logic_expression l
| EList l -> simpl_list_expression l
| ESet _ -> fail @@ unsupported_set_expr t
| ESet s -> simpl_set_expression s
| ECase c -> (
let (c , loc) = r_split c in
let%bind e = simpl_expression c.expr in
@ -571,6 +571,21 @@ and simpl_list_expression (t:Raw.list_expr) : expression result =
return @@ e_list ~loc []
)
and simpl_set_expression (t:Raw.set_expr) : expression result =
match t with
| SetMem x -> (
let (x' , loc) = r_split x in
let%bind set' = simpl_expression x'.set in
let%bind element' = simpl_expression x'.element in
ok @@ e_constant ~loc "SET_MEM" [ element' ; set' ]
)
| SetInj x -> (
let (x' , loc) = r_split x in
let elements = pseq_to_list x'.elements in
let%bind elements' = bind_map_list simpl_expression elements in
ok @@ e_set ~loc elements'
)
and simpl_binop (name:string) (t:_ Raw.bin_op Region.reg) : expression result =
let return x = ok x in
let (t , loc) = r_split t in

30
src/test/integration_tests.ml
View File

@ -159,6 +159,34 @@ let string_arithmetic () : unit result =
let%bind () = expect_fail program "slice_op" (e_string "ba") in
ok ()
let set_arithmetic () : unit result =
let%bind program = type_file "./contracts/set_arithmetic.ligo" in
let%bind () =
expect_eq program "add_op"
(e_set [e_string "foo" ; e_string "bar"])
(e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) in
let%bind () =
expect_eq program "add_op"
(e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"])
(e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"]) in
let%bind () =
expect_eq program "remove_op"
(e_set [e_string "foo" ; e_string "bar"])
(e_set [e_string "foo" ; e_string "bar"]) in
let%bind () =
expect_eq program "remove_op"
(e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"])
(e_set [e_string "foo" ; e_string "bar"]) in
let%bind () =
expect_eq program "mem_op"
(e_set [e_string "foo" ; e_string "bar" ; e_string "foobar"])
(e_bool true) in
let%bind () =
expect_eq program "mem_op"
(e_set [e_string "foo" ; e_string "bar"])
(e_bool false) in
ok ()
let unit_expression () : unit result =
let%bind program = type_file "./contracts/unit.ligo" in
expect_eq_evaluate program "u" (e_unit ())
@ -370,7 +398,6 @@ let loop () : unit result =
in
ok ()
let matching () : unit result =
let%bind program = type_file "./contracts/match.ligo" in
let%bind () =
@ -590,6 +617,7 @@ let main = test_suite "Integration (End to End)" [
test "arithmetic" arithmetic ;
test "bitiwse_arithmetic" bitwise_arithmetic ;
test "string_arithmetic" string_arithmetic ;
test "set_arithmetic" set_arithmetic ;
test "unit" unit_expression ;
test "string" string_expression ;
test "option" option ;

8
src/test/test_helpers.ml
View File

@ -32,7 +32,13 @@ let rec error_pp out (e : error) =
| `Null -> ""
| `List lst -> Format.asprintf "@[<v2>%a@]" PP_helpers.(list_sep error_pp (tag "@,")) lst
| _ -> " " ^ (J.to_string infos) ^ "\n" in
Format.fprintf out "%s%s%s.\n%s%s" title error_code message data infos
let children =
let children = e |> member "children" in
match children with
| `Null -> ""
| `List lst -> Format.asprintf "@[<v2>%a@]" PP_helpers.(list_sep error_pp (tag "@,")) lst
| _ -> " " ^ (J.to_string children) ^ "\n" in
Format.fprintf out "%s%s%s.\n%s%s%s" title error_code message data infos children
let test name f =

2
src/transpiler/transpiler.ml
View File

@ -372,7 +372,7 @@ and translate_annotated_expression (ae:AST.annotated_expression) : expression re
Mini_c.Combinators.get_t_set tv in
let%bind lst' = bind_map_list (translate_annotated_expression) lst in
let aux : expression -> expression -> expression result = fun prev cur ->
return @@ E_constant ("CONS", [cur ; prev]) in
return @@ E_constant ("SET_ADD", [cur ; prev]) in
let%bind (init : expression) = return @@ E_make_empty_set t in
bind_fold_list aux init lst'
)

8
vendors/ligo-utils/proto-alpha-utils/trace.ml vendored
View File

@ -26,10 +26,12 @@ let trace_tzresult err =
let trace_tzresult_r err_thunk_may_fail =
function
| Result.Ok x -> ok x
| Error _errs ->
(* let tz_errs = List.map of_tz_error errs in *)
| Error errs ->
let tz_errs = List.map of_tz_error errs in
match err_thunk_may_fail () with
| Simple_utils.Trace.Ok (err, annotations) -> ignore annotations; Error (err)
| Simple_utils.Trace.Ok (err, annotations) ->
ignore annotations ;
Error (fun () -> patch_children tz_errs (err ()))
| Error errors_while_generating_error ->
(* TODO: the complexity could be O(n*n) in the worst case,
this should use some catenable lists. *)