diff --git a/src/lib_utils/PP.ml b/src/lib_utils/PP.ml index ab9a5b422..70f6410d1 100644 --- a/src/lib_utils/PP.ml +++ b/src/lib_utils/PP.ml @@ -38,9 +38,8 @@ let map = fun f pp ppf x -> let pair_sep value sep ppf (a, b) = fprintf ppf "%a %s %a" value a sep value b let smap_sep value sep ppf m = let module SMap = X_map.String in - let aux k v prev = (k, v) :: prev in + let lst = SMap.to_kv_list m in let new_pp ppf (k, v) = fprintf ppf "%s -> %a" k value v in - let lst = List.rev @@ SMap.fold aux m [] in fprintf ppf "%a" (list_sep new_pp sep) lst (* TODO: remove all uses. this is bad. *) diff --git a/src/lib_utils/x_list.ml b/src/lib_utils/x_list.ml index 71d317810..f1986e488 100644 --- a/src/lib_utils/x_list.ml +++ b/src/lib_utils/x_list.ml @@ -115,7 +115,11 @@ let rev_uncons_opt = function let r = rev lst in let last = hd r in let hds = rev @@ tl r in - Some (hds, last) + Some (hds , last) + +let hds lst = match rev_uncons_opt lst with + | None -> failwith "toto" + | Some (hds , _) -> hds let to_pair = function | [a ; b] -> Some (a , b) diff --git a/src/ligo/ast_simplified/PP.ml b/src/ligo/ast_simplified/PP.ml index 028f9b5bc..6eed2f798 100644 --- a/src/ligo/ast_simplified/PP.ml +++ b/src/ligo/ast_simplified/PP.ml @@ -2,8 +2,14 @@ open Types open PP_helpers open Format -let list_sep_d x = list_sep x (const " , ") -let smap_sep_d x = smap_sep x (const " , ") +let list_sep_d x ppf lst = match lst with + | [] -> () + | _ -> fprintf ppf "@; @[%a@]@;" (list_sep x (tag "@;")) lst + +let smap_sep_d x ppf m = + if Map.String.is_empty m + then () + else fprintf ppf "@; @[%a@]@;" (smap_sep x (tag "@;")) m let rec type_expression ppf (te:type_expression) = match te with | T_tuple lst -> fprintf ppf "tuple[%a]" (list_sep_d type_expression) lst @@ -22,6 +28,7 @@ let literal ppf (l:literal) = match l with | Literal_string s -> fprintf ppf "%S" s | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b | Literal_address s -> fprintf ppf "@%S" s + | Literal_operation _ -> fprintf ppf "Operation(...bytes)" let rec expression ppf (e:expression) = match e with | E_literal l -> literal ppf l diff --git a/src/ligo/ast_simplified/combinators.ml b/src/ligo/ast_simplified/combinators.ml index 0ce8bc97b..517ff667a 100644 --- a/src/ligo/ast_simplified/combinators.ml +++ b/src/ligo/ast_simplified/combinators.ml @@ -171,3 +171,13 @@ let get_access_record : access -> string result = fun a -> | Access_tuple _ | Access_map _ -> simple_fail "not an access record" | Access_record s -> ok s + +let get_a_pair = fun t -> + match t.expression with + | E_tuple [a ; b] -> ok (a , b) + | _ -> simple_fail "not a pair" + +let get_a_list = fun t -> + match t.expression with + | E_list lst -> ok lst + | _ -> simple_fail "not a pair" diff --git a/src/ligo/ast_simplified/misc.ml b/src/ligo/ast_simplified/misc.ml index 8e7eadaf2..843307eed 100644 --- a/src/ligo/ast_simplified/misc.ml +++ b/src/ligo/ast_simplified/misc.ml @@ -26,10 +26,13 @@ let assert_literal_eq (a, b : literal * literal) : unit result = | Literal_address a, Literal_address b when a = b -> ok () | Literal_address _, Literal_address _ -> simple_fail "different addresss" | Literal_address _, _ -> simple_fail "address vs non-address" + | Literal_operation _, Literal_operation _ -> simple_fail "can't compare operations" + | Literal_operation _, _ -> simple_fail "operation vs non-operation" + let rec assert_value_eq (a, b: (value*value)) : unit result = let error_content () = - Format.asprintf "%a vs %a" PP.value a PP.value b + Format.asprintf "\n@[- %a@;- %a]" PP.value a PP.value b in trace (fun () -> error (thunk "not equal") error_content ()) @@ match (a.expression, b.expression) with diff --git a/src/ligo/ast_simplified/types.ml b/src/ligo/ast_simplified/types.ml index 117acc62b..adaf10689 100644 --- a/src/ligo/ast_simplified/types.ml +++ b/src/ligo/ast_simplified/types.ml @@ -88,6 +88,7 @@ and literal = | Literal_string of string | Literal_bytes of bytes | Literal_address of string + | Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation and block = instruction list and b = block diff --git a/src/ligo/ast_typed/PP.ml b/src/ligo/ast_typed/PP.ml index dfb410432..35bc1101e 100644 --- a/src/ligo/ast_typed/PP.ml +++ b/src/ligo/ast_typed/PP.ml @@ -63,6 +63,7 @@ and literal ppf (l:literal) : unit = | Literal_string s -> fprintf ppf "%s" s | Literal_bytes b -> fprintf ppf "0x%s" @@ Bytes.to_string @@ Bytes.escaped b | Literal_address s -> fprintf ppf "@%s" s + | Literal_operation _ -> fprintf ppf "Operation(...bytes)" and block ppf (b:block) = (list_sep instruction (tag "@;")) ppf b diff --git a/src/ligo/ast_typed/combinators.ml b/src/ligo/ast_typed/combinators.ml index e86848066..52d4f7b25 100644 --- a/src/ligo/ast_typed/combinators.ml +++ b/src/ligo/ast_typed/combinators.ml @@ -155,6 +155,7 @@ let e_tez n : expression = E_literal (Literal_tez n) let e_bool b : expression = E_literal (Literal_bool b) let e_string s : expression = E_literal (Literal_string s) let e_address s : expression = E_literal (Literal_address s) +let e_operation s : expression = E_literal (Literal_operation s) let e_pair a b : expression = E_tuple [a; b] let e_list lst : expression = E_list lst diff --git a/src/ligo/ast_typed/misc.ml b/src/ligo/ast_typed/misc.ml index 70df407d0..419f930e0 100644 --- a/src/ligo/ast_typed/misc.ml +++ b/src/ligo/ast_typed/misc.ml @@ -276,11 +276,13 @@ let assert_literal_eq (a, b : literal * literal) : unit result = | Literal_address a, Literal_address b when a = b -> ok () | Literal_address _, Literal_address _ -> simple_fail "different addresss" | Literal_address _, _ -> simple_fail "address vs non-address" + | Literal_operation _, Literal_operation _ -> simple_fail "can't compare operations" + | Literal_operation _, _ -> simple_fail "operation vs non-operation" let rec assert_value_eq (a, b: (value*value)) : unit result = let error_content () = - Format.asprintf "%a vs %a" PP.value a PP.value b + Format.asprintf "\n%a vs %a" PP.value a PP.value b in trace (fun () -> error (thunk "not equal") error_content ()) @@ match (a.expression, b.expression) with diff --git a/src/ligo/ast_typed/types.ml b/src/ligo/ast_typed/types.ml index 89051aaf6..ab6cee065 100644 --- a/src/ligo/ast_typed/types.ml +++ b/src/ligo/ast_typed/types.ml @@ -107,6 +107,7 @@ and literal = | Literal_string of string | Literal_bytes of bytes | Literal_address of string + | Literal_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation and block = instruction list and b = block diff --git a/src/ligo/compiler/compiler_program.ml b/src/ligo/compiler/compiler_program.ml index b5257a644..33828c320 100644 --- a/src/ligo/compiler/compiler_program.ml +++ b/src/ligo/compiler/compiler_program.ml @@ -74,6 +74,8 @@ let rec translate_value (v:value) : michelson result = match v with | D_list lst -> let%bind lst' = bind_map_list translate_value lst in ok @@ seq lst' + | D_operation _ -> + simple_fail "can't compile an operation" and translate_function (content:anon_function) : michelson result = let%bind body = translate_quote_body content in diff --git a/src/ligo/compiler/uncompiler.ml b/src/ligo/compiler/uncompiler.ml index cd3d32c21..4f4b24cfb 100644 --- a/src/ligo/compiler/uncompiler.ml +++ b/src/ligo/compiler/uncompiler.ml @@ -72,6 +72,8 @@ let rec translate_value (Ex_typed_value (ty, value)) : value result = bind_map_list aux lst' in ok @@ D_list lst'' + | (Operation_t _) , op -> + ok @@ D_operation op | ty, v -> let%bind error = let%bind m_data = diff --git a/src/ligo/mini_c/PP.ml b/src/ligo/mini_c/PP.ml index bf2b19798..6e03017fd 100644 --- a/src/ligo/mini_c/PP.ml +++ b/src/ligo/mini_c/PP.ml @@ -8,7 +8,6 @@ let space_sep ppf () = fprintf ppf " " let lr = fun ppf -> function `Left -> fprintf ppf "L" | `Right -> fprintf ppf "R" - let type_base ppf : type_base -> _ = function | Base_unit -> fprintf ppf "unit" | Base_bool -> fprintf ppf "bool" @@ -42,6 +41,7 @@ and environment ppf (x:environment) = let rec value ppf : value -> unit = function | D_bool b -> fprintf ppf "%b" b + | D_operation _ -> fprintf ppf "operation[...bytes]" | D_int n -> fprintf ppf "%d" n | D_nat n -> fprintf ppf "+%d" n | D_tez n -> fprintf ppf "%dtz" n diff --git a/src/ligo/mini_c/combinators.ml b/src/ligo/mini_c/combinators.ml index 3302459aa..5f5a061fb 100644 --- a/src/ligo/mini_c/combinators.ml +++ b/src/ligo/mini_c/combinators.ml @@ -115,6 +115,15 @@ let get_t_contract t = match t with | T_contract x -> ok x | _ -> fail @@ wrong_type "contract" t +let get_t_operation t = match t with + | T_base Base_operation -> ok () + | _ -> fail @@ wrong_type "operation" t + +let get_operation (v:value) = match v with + | D_operation x -> ok x + | _ -> simple_fail "not an operation" + + let get_last_statement ((b', _):block) : statement result = let aux lst = match lst with | [] -> simple_fail "get_last: empty list" diff --git a/src/ligo/mini_c/types.ml b/src/ligo/mini_c/types.ml index 74bd6e7ac..d37fb4daf 100644 --- a/src/ligo/mini_c/types.ml +++ b/src/ligo/mini_c/types.ml @@ -47,6 +47,7 @@ type value = | D_list of value list (* | `Macro of anon_macro ... The future. *) | D_function of anon_function + | D_operation of Memory_proto_alpha.Alpha_context.packed_internal_operation and selector = var_name list diff --git a/src/ligo/test/coase_tests.ml b/src/ligo/test/coase_tests.ml index 19b352e15..ca5fc18bb 100644 --- a/src/ligo/test/coase_tests.ml +++ b/src/ligo/test/coase_tests.ml @@ -164,23 +164,25 @@ let sell () = let sell_action = ez_e_a_record [ ("card_to_sell" , e_a_nat (n - 1)) ; ] in - let storage = basic 100 1000 (cards_ez first_owner n) (2 * n) in + let cards = cards_ez first_owner n in + let storage = basic 100 1000 cards (2 * n) in e_a_pair sell_action storage in - let make_expected = fun n -> - let ops = e_a_list [] t_operation in - let storage = - let cards = - cards_ez first_owner n @ - [(e_a_nat (2 * n) , card (e_a_address second_owner))] - in - basic 101 1000 cards ((2 * n) + 1) in - e_a_pair ops storage + let make_expecter : int -> annotated_expression -> unit result = fun n result -> + let%bind (ops , storage) = get_a_pair result in + let%bind () = + let%bind lst = get_a_list ops in + Assert.assert_list_size lst 1 in + let expected_storage = + let cards = List.hds @@ cards_ez first_owner n in + basic 99 1000 cards (2 * n) in + Ast_simplified.assert_value_eq (expected_storage , storage) in let%bind () = let amount = Memory_proto_alpha.Alpha_context.Tez.zero in - let options = Memory_proto_alpha.make_options ~amount () in - expect_eq_n_pos_small ~options program "sell_single" make_input make_expected in + let payer = first_contract in + let options = Memory_proto_alpha.make_options ~amount ~payer () in + expect_n_strict_pos_small ~options program "sell_single" make_input make_expecter in ok () in ok () @@ -189,5 +191,5 @@ let sell () = let main = "Coase (End to End)", [ test "buy" buy ; test "transfer" transfer ; - (* test "sell" sell ; *) + test "sell" sell ; ] diff --git a/src/ligo/test/test_helpers.ml b/src/ligo/test/test_helpers.ml index fbd7d5822..e24e8ac48 100644 --- a/src/ligo/test/test_helpers.ml +++ b/src/ligo/test/test_helpers.ml @@ -78,6 +78,9 @@ let expect_eq_n_pos_small ?options = expect_eq_n_aux ?options [0 ; 2 ; 10] let expect_eq_n_strict_pos_small ?options = expect_eq_n_aux ?options [2 ; 10] let expect_eq_n_pos_mid = expect_eq_n_aux [0 ; 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] + let expect_eq_b program entry_point make_expected = let aux b = let input = e_a_bool b in diff --git a/src/ligo/transpiler/transpiler.ml b/src/ligo/transpiler/transpiler.ml index 61cb952df..40b91042f 100644 --- a/src/ligo/transpiler/transpiler.ml +++ b/src/ligo/transpiler/transpiler.ml @@ -37,7 +37,12 @@ let rec translate_type (t:AST.type_value) : type_value result = | T_constant ("option", [o]) -> let%bind o' = translate_type o in ok (T_option o') - | T_constant (name, _) -> fail (fun () -> error (thunk "unrecognized type constant") (fun () -> name) ()) + | T_constant (name , lst) -> + let error = + let title () = "unrecognized type constant" in + let content () = Format.asprintf "%s (%d)" name (List.length lst) in + error title content in + fail error | T_sum m -> let node = Append_tree.of_list @@ list_of_map m in let aux a b : type_value result = @@ -203,6 +208,7 @@ and translate_literal : AST.literal -> value = fun l -> match l with | Literal_bytes s -> D_bytes s | Literal_string s -> D_string s | Literal_address s -> D_string s + | Literal_operation op -> D_operation op | Literal_unit -> D_unit and transpile_small_environment : AST.small_environment -> Environment.t result = fun x -> @@ -636,8 +642,17 @@ let rec untranspile (v : value) (t : AST.type_value) : AST.annotated_expression bind_map_list aux lst in return (E_list lst') ) - | T_constant _ -> - simple_fail "unknown type_constant" + | T_constant ("contract" , [_ty]) -> + simple_fail "can't untranspile contract" + | T_constant ("operation" , []) -> + let%bind op = get_operation v in + return (E_literal (Literal_operation op)) + | T_constant (name , lst) -> + let error = + let title () = "unknown type_constant" in + let content () = Format.asprintf "%s (%d)" name (List.length lst) in + error title content in + fail error | T_sum m -> let lst = kv_list_of_map m in let%bind node = match Append_tree.of_list lst with diff --git a/src/ligo/typer/typer.ml b/src/ligo/typer/typer.ml index d54941bf8..7936b166f 100644 --- a/src/ligo/typer/typer.ml +++ b/src/ligo/typer/typer.ml @@ -368,6 +368,8 @@ and type_annotated_expression : environment -> I.annotated_expression -> O.annot return (E_literal (Literal_tez n)) (t_tez ()) | E_literal (Literal_address s) -> return (e_address s) (t_address ()) + | E_literal (Literal_operation op) -> + return (e_operation op) (t_operation ()) (* Tuple *) | E_tuple lst -> let%bind lst' = bind_list @@ List.map (type_annotated_expression e) lst in @@ -605,6 +607,7 @@ let untype_literal (l:O.literal) : I.literal result = | Literal_string s -> ok (Literal_string s) | Literal_bytes b -> ok (Literal_bytes b) | Literal_address s -> ok (Literal_address s) + | Literal_operation s -> ok (Literal_operation s) let rec untype_annotated_expression (e:O.annotated_expression) : (I.annotated_expression) result = let open I in