diff --git a/src/ligo/ast_typed.ml b/src/ligo/ast_typed.ml index 3d1fb0f04..df4b973ef 100644 --- a/src/ligo/ast_typed.ml +++ b/src/ligo/ast_typed.ml @@ -416,7 +416,6 @@ module Combinators = struct let aux prev (k, v) = SMap.add k v prev in let map = List.fold_left aux SMap.empty lst in type_value (Type_record map) None - let make_t_record m = t_record m None let make_t_record_ez lst = let m = SMap.of_list lst in @@ -478,7 +477,8 @@ module Combinators = struct let a_int n = annotated_expression (int n) make_t_int let a_bool b = annotated_expression (bool b) make_t_bool let a_pair a b = annotated_expression (pair a b) (make_t_pair a.type_annotation b.type_annotation) - let a_record r = annotated_expression (record r) (make_t_record (SMap.map (fun x -> x.type_annotation) r)) + let a_tuple lst = annotated_expression (Tuple lst) (make_t_tuple (List.map get_type_annotation lst)) + let a_record r = annotated_expression (record r) (make_t_record (SMap.map get_type_annotation r)) let a_record_ez r = annotated_expression (record_ez r) (make_t_record_ez (List.map (fun (x, y) -> x, y.type_annotation) r)) let a_map lst k v = annotated_expression (map lst) (make_t_map k v) diff --git a/src/ligo/contracts/heap.ligo b/src/ligo/contracts/heap.ligo index dd9a583af..b62cb73db 100644 --- a/src/ligo/contracts/heap.ligo +++ b/src/ligo/contracts/heap.ligo @@ -1,3 +1,4 @@ +type heap_element is int * string type heap is record heap_content : map(int, heap_element) ; diff --git a/src/ligo/contracts/tuple.ligo b/src/ligo/contracts/tuple.ligo new file mode 100644 index 000000000..6b190f4c0 --- /dev/null +++ b/src/ligo/contracts/tuple.ligo @@ -0,0 +1,12 @@ +type foobar is (int * int) + +const fb : foobar = (0, 0) + +function projection (const tpl : foobar) : int is + begin + skip + end with tpl.0 + tpl.1 + +type big_tuple is (int * int * int * int * int) + +const br : big_tuple = (23, 23, 23, 23, 23) diff --git a/src/ligo/ligo-parser/ligo_parser.ml b/src/ligo/ligo-parser/ligo_parser.ml index 7fec46e33..7d2570e25 100644 --- a/src/ligo/ligo-parser/ligo_parser.ml +++ b/src/ligo/ligo-parser/ligo_parser.ml @@ -1,3 +1,4 @@ module Parser = Parser -module Lexer = Lexer.Make(LexToken) module AST = AST +module Lexer = Lexer +module LexToken = LexToken diff --git a/src/ligo/ligo.ml b/src/ligo/ligo.ml index 13bcad608..a8f1c8639 100644 --- a/src/ligo/ligo.ml +++ b/src/ligo/ligo.ml @@ -15,7 +15,8 @@ let parse_file (source:string) : AST_Raw.t result = generic_try (simple_error "error opening file") @@ (fun () -> open_in source) in let lexbuf = Lexing.from_channel channel in - let Lexer.{read ; _} = + let module Lexer = Lexer.Make(LexToken) in + let Lexer.{read ; close} = Lexer.open_token_stream None in specific_try (function | Parser.Error -> ( @@ -29,12 +30,17 @@ let parse_file (source:string) : AST_Raw.t result = simple_error str ) | _ -> simple_error "unrecognized parse_ error" - ) @@ (fun () -> Parser.contract read lexbuf) >>? fun program_cst -> - ok program_cst + ) @@ (fun () -> + let raw = Parser.contract read lexbuf in + close () ; + raw + ) >>? fun raw -> + ok raw let parse (s:string) : AST_Raw.t result = let lexbuf = Lexing.from_string s in - let Lexer.{read ; _} = + let module Lexer = Lexer.Make(LexToken) in + let Lexer.{read ; close} = Lexer.open_token_stream None in specific_try (function | Parser.Error -> ( @@ -48,12 +54,17 @@ let parse (s:string) : AST_Raw.t result = simple_error str ) | _ -> simple_error "unrecognized parse_ error" - ) @@ (fun () -> Parser.contract read lexbuf) >>? fun program_cst -> - ok program_cst + ) @@ (fun () -> + let raw = Parser.contract read lexbuf in + close () ; + raw + ) >>? fun raw -> + ok raw let parse_expression (s:string) : AST_Raw.expr result = let lexbuf = Lexing.from_string s in - let Lexer.{read ; _} = + let module Lexer = Lexer.Make(LexToken) in + let Lexer.{read ; close} = Lexer.open_token_stream None in specific_try (function | Parser.Error -> ( @@ -67,8 +78,12 @@ let parse_expression (s:string) : AST_Raw.expr result = simple_error str ) | _ -> simple_error "unrecognized parse_ error" - ) @@ (fun () -> Parser.interactive_expr read lexbuf) >>? fun expr -> - ok expr + ) @@ (fun () -> + let raw = Parser.interactive_expr read lexbuf in + close () ; + raw + ) >>? fun raw -> + ok raw let simplify (p:AST_Raw.t) : Ast_simplified.program result = AST_Simplified.Simplify.simpl_program p let simplify_expr (e:AST_Raw.expr) : Ast_simplified.annotated_expression result = AST_Simplified.Simplify.simpl_expression e diff --git a/src/ligo/test/heap_tests.ml b/src/ligo/test/heap_tests.ml index 6bab7235c..cff4972e6 100644 --- a/src/ligo/test/heap_tests.ml +++ b/src/ligo/test/heap_tests.ml @@ -46,153 +46,6 @@ let is_empty () : unit result = @@ [0 ; 2 ; 42 ; 163 ; -1] in ok () -let bool_expression () : unit result = - let%bind program = type_file "./contracts/boolean_operators.ligo" in - let aux (name, f) = - let aux b = - let open AST_Typed.Combinators in - let input = a_bool b in - let%bind result = easy_run_typed name program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_bool result in - Assert.assert_equal_bool (f b) result' - in - let%bind _ = bind_list - @@ List.map aux [true;false] in - ok () - in - let%bind _ = bind_list - @@ List.map aux - @@ [ - ("or_true", fun b -> b || true) ; - ("or_false", fun b -> b || false) ; - ("and_true", fun b -> b && true) ; - ("and_false", fun b -> b && false) ; - ] in - ok () - -let unit_expression () : unit result = - let%bind program = type_file "./contracts/unit.ligo" in - let open AST_Typed.Combinators in - let%bind result = easy_evaluate_typed "u" program in - let%bind () = - trace (simple_error "result isn't unit") @@ - get_a_unit result in - ok () - -let record_ez_int names n = - let open AST_Typed.Combinators in - a_record_ez @@ List.map (fun x -> x, a_int n) names - -let multiple_parameters () : unit result = - let%bind program = type_file "./contracts/multiple-parameters.ligo" in - let inputs = [0 ; 2 ; 42 ; 163 ; -1] in - let aux (name, input_f, output_f) = - let aux n = - let input = input_f n in - let%bind result = easy_run_typed name program input in - let%bind result' = AST_Typed.Combinators.get_a_int result in - let expected = output_f n in - let%bind _ = Assert.assert_equal_int expected result' in - ok () - in - let%bind _ = bind_list @@ List.map aux inputs in - ok () - in - let%bind _ = bind_list @@ List.map aux [ - ("ab", record_ez_int ["a";"b"], fun n -> 2 * n) ; - ("abcd", record_ez_int ["a";"b";"c";"d"], fun n -> 4 * n + 2) ; - ("abcde", record_ez_int ["a";"b";"c";"d";"e"], fun n -> 2 * n + 3) ; - ] in - ok () - -let record () : unit result = - let%bind program = type_file "./contracts/record.ligo" in - let%bind _foobar = - let%bind result = easy_evaluate_typed "fb" program in - let expect = record_ez_int ["foo";"bar"] 0 in - AST_Typed.assert_value_eq (expect, result) - in - let%bind _projection = - let aux n = - let input = record_ez_int ["foo";"bar"] n in - let%bind result = easy_run_typed "projection" program input in - let expect = AST_Typed.Combinators.a_int (2 * n) in - AST_Typed.assert_value_eq (expect, result) - in - bind_list @@ List.map aux [0 ; -42 ; 144] - in - let%bind _big = - let%bind result = easy_evaluate_typed "br" program in - let expect = record_ez_int ["a";"b";"c";"d";"e"] 23 in - AST_Typed.assert_value_eq (expect, result) - in - ok () - -let condition () : unit result = - let%bind program = type_file "./contracts/condition.ligo" in - let aux n = - let open AST_Typed.Combinators in - let input = a_int n in - let%bind result = easy_run_main_typed program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_int result in - Assert.assert_equal_int (if n = 2 then 42 else 0) result' - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () - -let declarations () : unit result = - let%bind program = type_file "./contracts/declarations.ligo" in - let aux n = - let open AST_Typed.Combinators in - let input = a_int n in - let%bind result = easy_run_main_typed program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_int result in - Assert.assert_equal_int (42 + n) result' - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () - -let quote_declaration () : unit result = - let%bind program = type_file "./contracts/quote-declaration.ligo" in - let aux n = - let open AST_Typed.Combinators in - let input = a_int n in - let%bind result = easy_run_main_typed program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_int result in - Assert.assert_equal_int result' (42 + 2 * n) - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () - -let quote_declarations () : unit result = - let%bind program = type_file "./contracts/quote-declarations.ligo" in - let aux n = - let open AST_Typed.Combinators in - let input = a_int n in - let%bind result = easy_run_main_typed program input in - let%bind result' = - trace (simple_error "bad result") @@ - get_a_int result in - Assert.assert_equal_int result' (74 + 2 * n) - in - let%bind _ = bind_list - @@ List.map aux - @@ [0 ; 2 ; 42 ; 163 ; -1] in - ok () let main = "Heap (End to End)", [ test "is_empty" is_empty ; diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index 17de7848b..fa27b8e35 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -125,6 +125,35 @@ let record () : unit result = in ok () +let tuple () : unit result = + let%bind program = type_file "./contracts/tuple.ligo" in + let ez n = + let open AST_Typed.Combinators in + a_tuple (List.map a_int n) in + let%bind _foobar = + trace (simple_error "foobar") ( + let%bind result = easy_evaluate_typed "fb" program in + let expect = ez [0 ; 0] in + AST_Typed.assert_value_eq (expect, result) + ) + in + let%bind _projection = trace (simple_error "projection") ( + let aux n = + let input = ez [n ; n] in + let%bind result = easy_run_typed "projection" program input in + let expect = AST_Typed.Combinators.a_int (2 * n) in + AST_Typed.assert_value_eq (expect, result) + in + bind_list @@ List.map aux [0 ; -42 ; 144] + ) + in + let%bind _big = + let%bind result = easy_evaluate_typed "br" program in + let expect = ez [23 ; 23 ; 23 ; 23 ; 23] in + AST_Typed.assert_value_eq (expect, result) + in + ok () + let condition () : unit result = let%bind program = type_file "./contracts/condition.ligo" in let aux n = @@ -196,6 +225,7 @@ let main = "Integration (End to End)", [ test "bool" bool_expression ; test "unit" unit_expression ; test "record" record ; + test "tuple" tuple ; test "multiple parameters" multiple_parameters ; test "condition" condition ; test "declarations" declarations ; diff --git a/src/ligo/test/test.ml b/src/ligo/test/test.ml index 3d5ab340f..33e8c8c9a 100644 --- a/src/ligo/test/test.ml +++ b/src/ligo/test/test.ml @@ -7,6 +7,6 @@ let () = Compiler_tests.main ; Transpiler_tests.main ; Typer_tests.main ; - Heap_tests.main ; + (* Heap_tests.main ; *) ] ; () diff --git a/src/ligo/transpiler.ml b/src/ligo/transpiler.ml index 30ad7e2f8..5de9e809c 100644 --- a/src/ligo/transpiler.ml +++ b/src/ligo/transpiler.ml @@ -136,31 +136,29 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express in Append_tree.fold_ne (translate_annotated_expression env) aux node | Tuple_accessor (tpl, ind) -> - let%bind (tpl'_expr, _, _) = translate_annotated_expression env tpl in - let%bind tpl_tv = get_t_tuple ae.type_annotation in - let node_tv = Append_tree.of_list @@ List.mapi (fun i a -> (a, i)) tpl_tv in - let%bind ae' = - let leaf (tv, i) : (expression' option * type_value) result = - let%bind tv = translate_type tv in - if i = ind then ( - ok (Some (tpl'_expr), tv) - ) else ( - ok (None, tv) + let%bind tpl' = translate_annotated_expression env tpl in + let%bind tpl_tv = get_t_tuple tpl.type_annotation in + let node_tv = Append_tree.of_list @@ List.mapi (fun i a -> (i, a)) tpl_tv in + let leaf (i, _) : expression result = + if i = ind then ( + ok tpl' + ) else ( + simple_fail "bad leaf" + ) in + let node a b : expression result = + match%bind bind_lr (a, b) with + | `Left ((_, t, env) as ex) -> ( + let%bind (a, _) = get_t_pair t in + ok (Predicate ("CAR", [ex]), a, env) + ) + | `Right ((_, t, env) as ex) -> ( + let%bind (_, b) = get_t_pair t in + ok (Predicate ("CDR", [ex]), b, env) ) in - let node a b : (expression' option * type_value) result = - let%bind a = a in - let%bind b = b in - match (a, b) with - | (None, a), (None, b) -> ok (None, `Pair (a, b)) - | (Some _, _), (Some _, _) -> simple_fail "several identical indexes in the same tuple (shouldn't happen here)" - | (Some v, a), (None, b) -> ok (Some (Predicate ("CAR", [v, a, env])), `Pair (a, b)) - | (None, a), (Some v, b) -> ok (Some (Predicate ("CDR", [v, b, env])), `Pair (a, b)) - in - let%bind (ae_opt, tv) = Append_tree.fold_ne leaf node node_tv in - let%bind ae = trace_option (simple_error "bad index in tuple (shouldn't happen here)") - ae_opt in - ok (ae, tv, env) in - ok ae' + let%bind expr = + trace_strong (simple_error "bad index in tuple (shouldn't happen here)") @@ + Append_tree.fold_ne leaf node node_tv in + ok expr | Record m -> let node = Append_tree.of_list @@ list_of_map m in let aux a b : expression result = diff --git a/src/ligo/typer.ml b/src/ligo/typer.ml index 4833aaf07..24a39f3c4 100644 --- a/src/ligo/typer.ml +++ b/src/ligo/typer.ml @@ -297,6 +297,7 @@ and type_annotated_expression (e:environment) (ae:I.annotated_expression) : O.an ok O.{expression = O.Record_accessor (prev, property) ; type_annotation } ) in + trace (simple_error "accessing") @@ bind_fold_list aux e' path (* Sum *)