From ffe73169eccfcc33f1e23eaa969a6606012d8b28 Mon Sep 17 00:00:00 2001 From: Galfour Date: Sat, 4 May 2019 09:40:48 +0000 Subject: [PATCH] fix records and tuples --- src/ligo/ast_simplified/PP.ml | 4 + src/ligo/ast_simplified/types.ml | 1 + src/ligo/compiler/compiler_program.ml | 232 +++++++++++++------------- src/ligo/contracts/record.ligo | 5 + src/ligo/contracts/tuple.ligo | 10 ++ src/ligo/mini_c/PP.ml | 6 +- src/ligo/simplify/pascaligo.ml | 6 +- src/ligo/test/integration_tests.ml | 28 +++- src/ligo/transpiler/transpiler.ml | 37 ++-- src/ligo/typer/typer.ml | 32 ++++ 10 files changed, 231 insertions(+), 130 deletions(-) diff --git a/src/ligo/ast_simplified/PP.ml b/src/ligo/ast_simplified/PP.ml index b96100f30..028f9b5bc 100644 --- a/src/ligo/ast_simplified/PP.ml +++ b/src/ligo/ast_simplified/PP.ml @@ -71,6 +71,9 @@ and block ppf (b:block) = (list_sep instruction (tag "@;")) ppf b and single_record_patch ppf ((p, ae) : string * ae) = fprintf ppf "%s <- %a" p annotated_expression ae +and single_tuple_patch ppf ((p, ae) : int * ae) = + fprintf ppf "%d <- %a" p annotated_expression ae + and matching_variant_case : type a . (_ -> a -> unit) -> _ -> (constructor_name * name) * a -> unit = fun f ppf ((c,n),a) -> fprintf ppf "| %s %s -> %a" c n f a @@ -92,6 +95,7 @@ and instruction ppf (i:instruction) = match i with | I_skip -> fprintf ppf "skip" | I_do ae -> fprintf ppf "do %a" annotated_expression ae | I_record_patch (name, path, lst) -> fprintf ppf "%s.%a[%a]" name access_path path (list_sep_d single_record_patch) lst + | I_tuple_patch (name, path, lst) -> fprintf ppf "%s.%a[%a]" name access_path path (list_sep_d single_tuple_patch) lst | I_loop (cond, b) -> fprintf ppf "while (%a) { %a }" annotated_expression cond block b | I_assignment {name;annotated_expression = ae} -> fprintf ppf "%s := %a" name annotated_expression ae diff --git a/src/ligo/ast_simplified/types.ml b/src/ligo/ast_simplified/types.ml index eabe06b94..117acc62b 100644 --- a/src/ligo/ast_simplified/types.ml +++ b/src/ligo/ast_simplified/types.ml @@ -99,6 +99,7 @@ and instruction = | I_skip | I_do of ae | I_record_patch of (name * access_path * (string * ae) list) + | I_tuple_patch of (name * access_path * (int * ae) list) and 'a matching = | Match_bool of { diff --git a/src/ligo/compiler/compiler_program.ml b/src/ligo/compiler/compiler_program.ml index 170f4aadc..16d19547f 100644 --- a/src/ligo/compiler/compiler_program.ml +++ b/src/ligo/compiler/compiler_program.ml @@ -402,115 +402,7 @@ and translate_expression ?(first=false) (expr:expression) : michelson result = and translate_statement ((s', w_env) as s:statement) : michelson result = let error_message () = Format.asprintf "%a" PP.statement s in - let%bind (code : michelson) = - trace (fun () -> error (thunk "compiling statement") error_message ()) @@ match s' with - | S_environment_extend -> - ok @@ Compiler_environment.to_michelson_extend w_env.pre_environment - | S_environment_restrict -> - Compiler_environment.to_michelson_restrict w_env.pre_environment - | S_environment_add _ -> - simple_fail "add not ready yet" - (* | S_environment_add (name, tv) -> - * Environment.to_michelson_add (name, tv) w_env.pre_environment *) - | S_declaration (s, expr) -> - let tv = Combinators.Expression.get_type expr in - let%bind expr = translate_expression expr in - let%bind add = Compiler_environment.to_michelson_add (s, tv) w_env.pre_environment in - ok (seq [ - i_comment "declaration" ; - seq [ - i_comment "expr" ; - i_push_unit ; expr ; i_car ; - ] ; - seq [ - i_comment "env <- env . expr" ; - add ; - ]; - ]) - | S_assignment (s, expr) -> - let%bind expr = translate_expression expr in - let%bind set = Compiler_environment.to_michelson_set s w_env.pre_environment in - ok (seq [ - i_comment "assignment" ; - seq [ - i_comment "expr" ; - i_push_unit ; expr ; i_car ; - ] ; - seq [ - i_comment "env <- env . expr" ; - set ; - ]; - ]) - | S_cond (expr, a, b) -> - let%bind expr = translate_expression expr in - let%bind a' = translate_regular_block a in - let%bind b' = translate_regular_block b in - ok @@ (seq [ - i_push_unit ; - expr ; - prim I_CAR ; - prim ~children:[seq [a'];seq [b']] I_IF ; - ]) - | S_do expr -> ( - match Combinators.Expression.get_content expr with - | E_constant ("FAILWITH" , [ fw ] ) -> ( - let%bind fw' = translate_expression fw in - ok @@ seq [ - i_push_unit ; - fw' ; - i_car ; - i_failwith ; - ] - ) - | _ -> ( - let%bind expr' = translate_expression expr in - ok @@ seq [ - i_push_unit ; - expr' ; - i_drop ; - ] - ) - ) - | S_if_none (expr, none, ((name, tv), some)) -> - let%bind expr = translate_expression expr in - let%bind none' = translate_regular_block none in - let%bind some' = translate_regular_block some in - let%bind add = - let env' = Environment.extend w_env.pre_environment in - Compiler_environment.to_michelson_add (name, tv) env' in - ok @@ (seq [ - i_push_unit ; expr ; i_car ; - prim ~children:[ - seq [none'] ; - seq [add ; some'] ; - ] I_IF_NONE - ]) - | S_while (expr, block) -> - let%bind expr = translate_expression expr in - let%bind block' = translate_regular_block block in - let%bind restrict_block = - let env_while = (snd block).pre_environment in - Compiler_environment.to_michelson_restrict env_while in - ok @@ (seq [ - i_push_unit ; expr ; i_car ; - prim ~children:[seq [ - Compiler_environment.to_michelson_extend w_env.pre_environment; - block' ; - restrict_block ; - i_push_unit ; expr ; i_car]] I_LOOP ; - ]) - | S_patch (name, lrs, expr) -> - let%bind expr' = translate_expression expr in - let%bind (name_path, _) = Environment.get_path name w_env.pre_environment in - let path = name_path @ lrs in - let set_code = Compiler_environment.path_to_michelson_set path in - ok @@ seq [ - i_push_unit ; expr' ; i_car ; - set_code ; - ] - in - - let%bind () = + let return code = let%bind (Ex_ty pre_ty) = Compiler_environment.to_ty w_env.pre_environment in let input_stack_ty = Stack.(pre_ty @: nil) in let%bind (Ex_ty post_ty) = Compiler_environment.to_ty w_env.post_environment in @@ -533,11 +425,127 @@ and translate_statement ((s', w_env) as s:statement) : michelson result = Tezos_utils.Memory_proto_alpha.parse_michelson_fail code input_stack_ty output_stack_ty in - ok () + ok code in - - ok code + trace (fun () -> error (thunk "compiling statement") error_message ()) @@ match s' with + | S_environment_extend -> + return @@ Compiler_environment.to_michelson_extend w_env.pre_environment + | S_environment_restrict -> + let%bind code = Compiler_environment.to_michelson_restrict w_env.pre_environment in + return code + | S_environment_add _ -> + simple_fail "add not ready yet" + (* | S_environment_add (name, tv) -> + * Environment.to_michelson_add (name, tv) w_env.pre_environment *) + | S_declaration (s, expr) -> + let tv = Combinators.Expression.get_type expr in + let%bind expr = translate_expression expr in + let%bind add = Compiler_environment.to_michelson_add (s, tv) w_env.pre_environment in + return @@ seq [ + i_comment "declaration" ; + seq [ + i_comment "expr" ; + i_push_unit ; expr ; i_car ; + ] ; + seq [ + i_comment "env <- env . expr" ; + add ; + ]; + ] + | S_assignment (s, expr) -> + let%bind expr = translate_expression expr in + let%bind set = Compiler_environment.to_michelson_set s w_env.pre_environment in + return @@ seq [ + i_comment "assignment" ; + seq [ + i_comment "expr" ; + i_push_unit ; expr ; i_car ; + ] ; + seq [ + i_comment "env <- env . expr" ; + set ; + ]; + ] + | S_cond (expr, a, b) -> + let%bind expr = translate_expression expr in + let%bind a' = translate_regular_block a in + let%bind b' = translate_regular_block b in + return @@ seq [ + i_push_unit ; + expr ; + prim I_CAR ; + prim ~children:[seq [a'];seq [b']] I_IF ; + ] + | S_do expr -> ( + match Combinators.Expression.get_content expr with + | E_constant ("FAILWITH" , [ fw ] ) -> ( + let%bind fw' = translate_expression fw in + return @@ seq [ + i_push_unit ; + fw' ; + i_car ; + i_failwith ; + ] + ) + | _ -> ( + let%bind expr' = translate_expression expr in + return @@ seq [ + i_push_unit ; + expr' ; + i_drop ; + ] + ) + ) + | S_if_none (expr, none, ((name, tv), some)) -> + let%bind expr = translate_expression expr in + let%bind none' = translate_regular_block none in + let%bind some' = translate_regular_block some in + let%bind add = + let env' = Environment.extend w_env.pre_environment in + Compiler_environment.to_michelson_add (name, tv) env' in + return @@ seq [ + i_push_unit ; expr ; i_car ; + prim ~children:[ + seq [none'] ; + seq [add ; some'] ; + ] I_IF_NONE + ] + | S_while (expr, block) -> + let%bind expr = translate_expression expr in + let%bind block' = translate_regular_block block in + let%bind restrict_block = + let env_while = (snd block).pre_environment in + Compiler_environment.to_michelson_restrict env_while in + return @@ seq [ + i_push_unit ; expr ; i_car ; + prim ~children:[seq [ + Compiler_environment.to_michelson_extend w_env.pre_environment; + block' ; + restrict_block ; + i_push_unit ; expr ; i_car]] I_LOOP ; + ] + | S_patch (name, lrs, expr) -> + let%bind expr' = translate_expression expr in + let%bind (name_path, _) = Environment.get_path name w_env.pre_environment in + let path = name_path @ lrs in + let set_code = Compiler_environment.path_to_michelson_set path in + let error = + let title () = "michelson type-checking patch" in + let content () = + let aux ppf = function + | `Left -> Format.fprintf ppf "left" + | `Right -> Format.fprintf ppf "right" in + Format.asprintf "Name path: %a\nSub path: %a\n" + PP_helpers.(list_sep aux (const " , ")) name_path + PP_helpers.(list_sep aux (const " , ")) lrs + in + error title content in + trace error @@ + return @@ seq [ + i_push_unit ; expr' ; i_car ; + set_code ; + ] and translate_regular_block ((b, env):block) : michelson result = let aux prev statement = diff --git a/src/ligo/contracts/record.ligo b/src/ligo/contracts/record.ligo index 6a0171bd7..e0fbb5d04 100644 --- a/src/ligo/contracts/record.ligo +++ b/src/ligo/contracts/record.ligo @@ -34,6 +34,11 @@ function modify (const r : foobar) : foobar is r.foo := 256 ; } with r +function modify_abc (const r : abc) : abc is + block { + r.b := 2048 ; + } with r + type big_record is record a : int ; b : int ; diff --git a/src/ligo/contracts/tuple.ligo b/src/ligo/contracts/tuple.ligo index 6b190f4c0..aebdc7b87 100644 --- a/src/ligo/contracts/tuple.ligo +++ b/src/ligo/contracts/tuple.ligo @@ -10,3 +10,13 @@ function projection (const tpl : foobar) : int is type big_tuple is (int * int * int * int * int) const br : big_tuple = (23, 23, 23, 23, 23) + +type abc is (int * int * int) + +function projection_abc (const tpl : abc) : int is + block { skip } with tpl.1 + +function modify_abc (const tpl : abc) : abc is + block { + tpl.1 := 2048 ; + } with tpl diff --git a/src/ligo/mini_c/PP.ml b/src/ligo/mini_c/PP.ml index a896caa63..c20198de2 100644 --- a/src/ligo/mini_c/PP.ml +++ b/src/ligo/mini_c/PP.ml @@ -6,6 +6,9 @@ let list_sep_d x = list_sep x (const " , ") 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" @@ -114,8 +117,7 @@ and statement ppf ((s, _) : statement) = match s with | S_do e -> fprintf ppf "do %a" expression e | S_cond (expr, i, e) -> fprintf ppf "if (%a) %a %a" expression expr block i block e | S_patch (r, path, e) -> - let aux = fun ppf -> function `Left -> fprintf ppf ".L" | `Right -> fprintf ppf ".R" in - fprintf ppf "%s%a := %a" r (list aux) path expression e + fprintf ppf "%s.%a := %a" r (list_sep lr (const ".")) path expression e | S_if_none (expr, none, ((name, _), some)) -> fprintf ppf "if_none (%a) %a %s->%a" expression expr block none name block some | S_while (e, b) -> fprintf ppf "while (%a) %a" expression e block b diff --git a/src/ligo/simplify/pascaligo.ml b/src/ligo/simplify/pascaligo.ml index deef5d63b..93415e802 100644 --- a/src/ligo/simplify/pascaligo.ml +++ b/src/ligo/simplify/pascaligo.ml @@ -435,8 +435,10 @@ and simpl_single_instruction : Raw.single_instr -> instruction result = fun t -> ok @@ I_assignment {name ; annotated_expression = value_expr} ) | Some (hds , last) -> ( - let%bind property = get_access_record last in - ok @@ I_record_patch (name , hds , [(property , value_expr)]) + match last with + | Access_record property -> ok @@ I_record_patch (name , hds , [(property , value_expr)]) + | Access_tuple index -> ok @@ I_tuple_patch (name , hds , [(index , value_expr)]) + | _ -> simple_fail "no map assignment in this weird case yet" ) ) | MapPath v -> ( diff --git a/src/ligo/test/integration_tests.ml b/src/ligo/test/integration_tests.ml index 06b62be73..c32055762 100644 --- a/src/ligo/test/integration_tests.ml +++ b/src/ligo/test/integration_tests.ml @@ -156,6 +156,15 @@ let record () : unit result = let make_expected = fun n -> ez_e_a_record [("foo" , e_a_int 256) ; ("bar" , e_a_int n) ] in expect_n program "modify" make_input make_expected in + let%bind () = + let make_input = record_ez_int ["a" ; "b" ; "c"] in + let make_expected = fun n -> ez_e_a_record [ + ("a" , e_a_int n) ; + ("b" , e_a_int 2048) ; + ("c" , e_a_int n) + ] in + expect_n program "modify_abc" make_input make_expected + in let%bind () = let expected = record_ez_int ["a";"b";"c";"d";"e"] 23 in expect_evaluate program "br" expected @@ -175,6 +184,21 @@ let tuple () : unit result = let make_expected = fun n -> e_a_int (2 * n) in expect_n program "projection" make_input make_expected in + let%bind () = + let make_input = fun n -> ez [n ; 2 * n ; n] in + let make_expected = fun n -> e_a_int (2 * n) in + expect_n program "projection_abc" make_input make_expected + in + let%bind () = + let make_input = fun n -> ez [n ; n ; n] in + let make_expected = fun n -> ez [n ; 2048 ; n] in + expect program "modify_abc" (make_input 12) (make_expected 12) + in + let%bind () = + let make_input = fun n -> ez [n ; n ; n] in + let make_expected = fun n -> ez [n ; 2048 ; n] in + expect_n program "modify_abc" make_input make_expected + in let%bind () = let expected = ez [23 ; 23 ; 23 ; 23 ; 23] in expect_evaluate program "br" expected @@ -383,6 +407,8 @@ let main = "Integration (End to End)", [ test "complex function" complex_function ; test "variant" variant ; test "variant matching" variant_matching ; + test "tuple" tuple ; + test "record" record ; test "closure" closure ; test "shared function" shared_function ; test "shadow" shadow ; @@ -390,8 +416,6 @@ let main = "Integration (End to End)", [ test "bool" bool_expression ; test "arithmetic" arithmetic ; test "unit" unit_expression ; - test "record" record ; - test "tuple" tuple ; test "option" option ; test "map" map ; test "list" list ; diff --git a/src/ligo/transpiler/transpiler.ml b/src/ligo/transpiler/transpiler.ml index 0b0868757..5e9d31a02 100644 --- a/src/ligo/transpiler/transpiler.ml +++ b/src/ligo/transpiler/transpiler.ml @@ -71,11 +71,24 @@ let tuple_access_to_lr : type_value -> type_value list -> int -> (type_value * [ Append_tree.exists_path aux node_tv in let lr_path = List.map (fun b -> if b then `Right else `Left) path in let%bind (_ , lst) = - let aux = fun (ty , acc) cur -> - let%bind (a , b) = Mini_c.get_t_pair ty in + let aux = fun (ty' , acc) cur -> + let%bind (a , b) = + let error = + let title () = "expected a pair" in + let content () = Format.asprintf "Big: %a.\tGot: %a\tFull path: %a\tSmall path: %a" + Mini_c.PP.type_ ty + Mini_c.PP.type_ ty' + PP_helpers.(list_sep bool (const ".")) path + PP_helpers.(list_sep lr (const ".")) (List.map snd acc) + in + error title content + in + trace_strong error @@ + Mini_c.get_t_pair ty' in match cur with - | `Left -> ok (a , (a , `Left) :: acc) - | `Right -> ok (b , (b , `Right) :: acc) in + | `Left -> ok (a , acc @ [(a , `Left)]) + | `Right -> ok (b , acc @ [(b , `Right)]) + in bind_fold_list aux (ty , []) lr_path in ok lst @@ -91,8 +104,8 @@ let record_access_to_lr : type_value -> type_value AST.type_name_map -> string - let aux = fun (ty , acc) cur -> let%bind (a , b) = Mini_c.get_t_pair ty in match cur with - | `Left -> ok (a , (a , `Left) :: acc) - | `Right -> ok (b , (b , `Right) :: acc) in + | `Left -> ok (a , acc @ [(a , `Left)]) + | `Right -> ok (b , acc @ [(b , `Right)] ) in bind_fold_list aux (ty , []) lr_path in ok lst @@ -125,12 +138,12 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li let%bind ty'_lst = bind_map_list translate_type ty_lst in let%bind path = tuple_access_to_lr ty' ty'_lst ind in let path' = List.map snd path in - ok (List.nth ty_lst ind, path' @ acc) + ok (List.nth ty_lst ind, acc @ path') | Access_record prop -> let%bind ty_map = let error = let title () = "accessing property on not a record" in - let content () = Format.asprintf "%s on %a in %a" + let content () = Format.asprintf "%s on %a in %a" prop Ast_typed.PP.type_value prev Ast_typed.PP.instruction i in error title content in @@ -139,10 +152,10 @@ and translate_instruction (env:Environment.t) (i:AST.instruction) : statement li let%bind ty'_map = bind_map_smap translate_type ty_map in let%bind path = record_access_to_lr ty' ty'_map prop in let path' = List.map snd path in - ok (Map.String.find prop ty_map, path' @ acc) + ok (Map.String.find prop ty_map, acc @ path') | Access_map _k -> simple_fail "no patch for map yet" in - let%bind (_, path) = bind_fold_list aux (ty, []) s in + let%bind (_, path) = bind_fold_right_list aux (ty, []) s in let%bind v' = translate_annotated_expression env v in return (S_patch (r.type_name, path, v')) ) @@ -279,7 +292,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express | `Right -> "CDR" in Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty , env) in let%bind tpl' = translate_annotated_expression env tpl in - let expr = List.fold_right' aux tpl' path in + let expr = List.fold_left aux tpl' path in ok expr | E_record m -> let node = Append_tree.of_list @@ list_of_map m in @@ -303,7 +316,7 @@ and translate_annotated_expression (env:Environment.t) (ae:AST.annotated_express | `Right -> "CDR" in Combinators.Expression.make_tpl (E_constant (c, [pred]) , ty , env) in let%bind record' = translate_annotated_expression env record in - let expr = List.fold_right' aux record' path in + let expr = List.fold_left aux record' path in ok expr | E_constant (name, lst) -> let%bind lst' = bind_list @@ List.map (translate_annotated_expression env) lst in ( diff --git a/src/ligo/typer/typer.ml b/src/ligo/typer/typer.ml index 17f7ef80b..a6154d4e0 100644 --- a/src/ligo/typer/typer.ml +++ b/src/ligo/typer/typer.ml @@ -177,6 +177,38 @@ and type_instruction (e:environment) : I.instruction -> (environment * O.instruc in let%bind lst' = bind_map_list aux lst in ok (e, lst') + | I_tuple_patch (r, path, lst) -> + let aux (s, ae) = + let%bind ae' = type_annotated_expression e ae in + let%bind ty = + trace_option (simple_error "unbound variable in tuple_patch") @@ + Environment.get_opt r e in + let tv = O.{type_name = r ; type_value = ty.type_value} in + let aux ty access = + match access with + | I.Access_record s -> + let%bind m = O.Combinators.get_t_record ty in + let%bind ty = + trace_option (simple_error "unbound record access in tuple_patch") @@ + Map.String.find_opt s m in + ok (ty , O.Access_record s) + | I.Access_tuple i -> + let%bind t = O.Combinators.get_t_tuple ty in + let%bind ty = + generic_try (simple_error "unbound tuple access in tuple_patch") @@ + (fun () -> List.nth t i) in + ok (ty , O.Access_tuple i) + | I.Access_map ind -> + let%bind (k , v) = O.Combinators.get_t_map ty in + let%bind ind' = type_annotated_expression e ind in + let%bind () = Ast_typed.assert_type_value_eq (get_type_annotation ind' , k) in + ok (v , O.Access_map ind') + in + let%bind path' = bind_fold_map_list aux ty.type_value (path @ [Access_tuple s]) in + ok @@ O.I_patch (tv, path', ae') + in + let%bind lst' = bind_map_list aux lst in + ok (e, lst') and type_match : type i o . (environment -> i -> o result) -> environment -> O.type_value -> i I.matching -> o O.matching result =