From 1f6bc4fc6bb30f6bb4e908a3c39d697e1a2c57a8 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Tue, 28 Apr 2020 00:34:03 +0200 Subject: [PATCH] convert_from for pairs/record --- src/bin/expect_tests/michelson_converter.ml | 46 ++++++ src/passes/10-transpiler/transpiler.ml | 2 + .../8-typer-new/todo_use_fold_generator.ml | 2 + src/passes/8-typer-new/untyper.ml | 2 + src/passes/8-typer-old/typer.ml | 4 + .../9-self_ast_typed/michelson_layout.ml | 151 ++++++++++++------ src/passes/operators/helpers.ml | 45 +++++- src/passes/operators/helpers.mli | 2 + src/passes/operators/operators.ml | 23 ++- src/stages/4-ast_typed/PP.ml | 2 + src/stages/4-ast_typed/types.ml | 2 + src/stages/5-mini_c/PP.ml | 2 + src/stages/common/PP.ml | 2 + src/stages/common/types.ml | 2 + src/test/contracts/michelson_converter.mligo | 26 ++- 15 files changed, 252 insertions(+), 61 deletions(-) diff --git a/src/bin/expect_tests/michelson_converter.ml b/src/bin/expect_tests/michelson_converter.ml index 67c10ba81..81b0d9fc9 100644 --- a/src/bin/expect_tests/michelson_converter.ml +++ b/src/bin/expect_tests/michelson_converter.ml @@ -44,6 +44,52 @@ let%expect_test _ = [%expect {| ( ( ( 2 , +3 ) , "q" ) , true ) |}] +let%expect_test _ = + run_ligo_good [ "dry-run" ; (contract "michelson_converter.mligo") ; "main_r" ; "test_input_pair_r" ; "s"] ; + [%expect {| + ( LIST_EMPTY() , "eqeq" ) |}] ; + run_ligo_good [ "compile-contract" ; (contract "michelson_converter.mligo") ; "main_r" ] ; + [%expect {| + { parameter (pair (int %one) (pair (nat %two) (pair (string %three) (bool %four)))) ; + storage string ; + code { DUP ; + CAR ; + DUP ; + CDR ; + CDR ; + CAR ; + DIG 1 ; + DUP ; + DUG 2 ; + CDR ; + CDR ; + CAR ; + CONCAT ; + NIL operation ; + PAIR ; + DIP { DROP 2 } } } |}]; + run_ligo_good [ "dry-run" ; (contract "michelson_converter.mligo") ; "main_l" ; "test_input_pair_l" ; "s"] ; + [%expect {| + ( LIST_EMPTY() , "eqeq" ) |}] ; + run_ligo_good [ "compile-contract" ; (contract "michelson_converter.mligo") ; "main_l" ] ; + [%expect {| + { parameter (pair (pair (pair (int %one) (nat %two)) (string %three)) (bool %four)) ; + storage string ; + code { DUP ; + CAR ; + DUP ; + CAR ; + CDR ; + DIG 1 ; + DUP ; + DUG 2 ; + CAR ; + CDR ; + CONCAT ; + NIL operation ; + PAIR ; + DIP { DROP 2 } } } |}] + let%expect_test _ = run_ligo_good [ "compile-contract" ; contract "michelson_comb_type_operators.mligo" ; "main_r"] ; [%expect {| diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 4e0055b4e..1a2bec98b 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -230,6 +230,8 @@ let transpile_constant' : AST.constant' -> constant' = function | C_CREATE_CONTRACT -> C_CREATE_CONTRACT | C_CONVERT_TO_LEFT_COMB -> C_CONVERT_TO_LEFT_COMB | C_CONVERT_TO_RIGHT_COMB -> C_CONVERT_TO_RIGHT_COMB + | C_CONVERT_FROM_LEFT_COMB -> C_CONVERT_FROM_LEFT_COMB + | C_CONVERT_FROM_RIGHT_COMB -> C_CONVERT_FROM_RIGHT_COMB let rec transpile_type (t:AST.type_expression) : type_value result = match t.type_content with diff --git a/src/passes/8-typer-new/todo_use_fold_generator.ml b/src/passes/8-typer-new/todo_use_fold_generator.ml index 097426109..22346cbf1 100644 --- a/src/passes/8-typer-new/todo_use_fold_generator.ml +++ b/src/passes/8-typer-new/todo_use_fold_generator.ml @@ -135,3 +135,5 @@ let convert_constant' : I.constant' -> O.constant' = function | C_CREATE_CONTRACT -> C_CREATE_CONTRACT | C_CONVERT_TO_LEFT_COMB -> C_CONVERT_TO_LEFT_COMB | C_CONVERT_TO_RIGHT_COMB -> C_CONVERT_TO_RIGHT_COMB + | C_CONVERT_FROM_LEFT_COMB -> C_CONVERT_FROM_LEFT_COMB + | C_CONVERT_FROM_RIGHT_COMB -> C_CONVERT_FROM_RIGHT_COMB diff --git a/src/passes/8-typer-new/untyper.ml b/src/passes/8-typer-new/untyper.ml index 3fd9f4320..1ceeb2f52 100644 --- a/src/passes/8-typer-new/untyper.ml +++ b/src/passes/8-typer-new/untyper.ml @@ -137,6 +137,8 @@ let unconvert_constant' : O.constant' -> I.constant' = function | C_CREATE_CONTRACT -> C_CREATE_CONTRACT | C_CONVERT_TO_LEFT_COMB -> C_CONVERT_TO_LEFT_COMB | C_CONVERT_TO_RIGHT_COMB -> C_CONVERT_TO_RIGHT_COMB + | C_CONVERT_FROM_LEFT_COMB -> C_CONVERT_FROM_LEFT_COMB + | C_CONVERT_FROM_RIGHT_COMB -> C_CONVERT_FROM_RIGHT_COMB let untype_type_value (t:O.type_expression) : (I.type_expression) result = match t.type_meta with diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index 76a20edd5..de04bb9d4 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -360,6 +360,8 @@ let convert_constant' : I.constant' -> O.constant' = function | C_CREATE_CONTRACT -> C_CREATE_CONTRACT | C_CONVERT_TO_LEFT_COMB -> C_CONVERT_TO_LEFT_COMB | C_CONVERT_TO_RIGHT_COMB -> C_CONVERT_TO_RIGHT_COMB + | C_CONVERT_FROM_LEFT_COMB -> C_CONVERT_FROM_LEFT_COMB + | C_CONVERT_FROM_RIGHT_COMB -> C_CONVERT_FROM_RIGHT_COMB let unconvert_constant' : O.constant' -> I.constant' = function | C_INT -> C_INT @@ -477,6 +479,8 @@ let unconvert_constant' : O.constant' -> I.constant' = function | C_CREATE_CONTRACT -> C_CREATE_CONTRACT | C_CONVERT_TO_LEFT_COMB -> C_CONVERT_TO_LEFT_COMB | C_CONVERT_TO_RIGHT_COMB -> C_CONVERT_TO_RIGHT_COMB + | C_CONVERT_FROM_LEFT_COMB -> C_CONVERT_FROM_LEFT_COMB + | C_CONVERT_FROM_RIGHT_COMB -> C_CONVERT_FROM_RIGHT_COMB let rec type_program (p:I.program) : (O.program * O.typer_state) result = let aux (e, acc:(environment * O.declaration Location.wrap list)) (d:I.declaration Location.wrap) = diff --git a/src/passes/9-self_ast_typed/michelson_layout.ml b/src/passes/9-self_ast_typed/michelson_layout.ml index abfd39bd7..968b2b078 100644 --- a/src/passes/9-self_ast_typed/michelson_layout.ml +++ b/src/passes/9-self_ast_typed/michelson_layout.ml @@ -1,62 +1,115 @@ open Ast_typed open Trace -let get_label_map_from_env (v:expression_variable) (env: full_environment) : expression_label_map result = - let%bind a = trace_option (simple_error "corner case") @@ - Environment.get_opt v env in - ( match a.definition with - | ED_declaration { expr = {expression_content = E_record lmap_e;_} ; _} -> ok lmap_e - | _ -> simple_fail "corner case" ) +let to_sorted_kv_list lmap = + List.sort (fun (_,{decl_position=a;_}) (_,{decl_position=b;}) -> Int.compare a b) @@ + LMap.to_kv_list lmap -let rec to_right_comb_e l new_map = +let accessor (record:expression) (path:label) (t:type_expression) = + { expression_content = E_record_accessor {record; path} ; + location = Location.generated ; + type_expression = t ; + environment = record.environment} + +let rec to_left_comb' first prev l conv_map = match l with - | [] -> new_map - | [ (_, expl) ; (_ , expr) ] -> - LMap.add_bindings [ (Label "0" , expl) ; (Label "1" , expr) ] new_map - | (_, exp)::tl -> - let new_map' = LMap.add (Label "0") exp new_map in - LMap.add (Label "1") ({exp with expression_content = E_record (to_right_comb_e tl new_map')}) new_map' + | [] -> conv_map + | (label_l, {field_type=t_l}) :: (label_r, {field_type=t_r})::tl when first -> + let exp_l = accessor prev label_l t_l in + let exp_r = accessor prev label_r t_r in + let conv_map' = LMap.add_bindings [ (Label "0" , exp_l) ; (Label "1" , exp_r) ] LMap.empty in + to_left_comb' false prev tl conv_map' + | (label, {field_type=t})::tl -> + let conv_map' = LMap.add_bindings [ + (Label "0" , {prev with expression_content = E_record conv_map}); + (Label "1" , accessor prev label t)] + LMap.empty in + to_left_comb' first prev tl conv_map' -let rec to_left_comb_e_ first l new_map = +let to_left_comb = to_left_comb' true + +let rec to_right_comb + (prev:expression) + (l:(label * field_content) list) + (conv_map: expression label_map) : expression label_map = match l with - | [] -> new_map - | (_, expl) :: (_, expr) ::tl when first -> - let new_map' = LMap.add_bindings [ (Label "0" , expl) ; (Label "1" , expr) ] LMap.empty in - to_left_comb_e_ false tl new_map' - | (_,exp)::tl -> - let new_map' = LMap.add_bindings [ - (Label "0" , {exp with expression_content = E_record new_map}); - (Label "1" , exp ) ;] LMap.empty in - to_left_comb_e_ first tl new_map' + | [] -> conv_map + | [ (label_l,{field_type=tl}) ; (label_r,{field_type=tr}) ] -> + let exp_l = accessor prev label_l tl in + let exp_r = accessor prev label_r tr in + LMap.add_bindings [ (Label "0" , exp_l) ; (Label "1" , exp_r) ] conv_map + | (label,{field_type})::tl -> + let exp = { expression_content = E_record_accessor {record = prev ; path = label } ; + location = Location.generated ; + type_expression = field_type ; + environment = prev.environment } in + let conv_map' = LMap.add (Label "0") exp conv_map in + LMap.add (Label "1") ({exp with expression_content = E_record (to_right_comb prev tl conv_map')}) conv_map' -let to_left_comb_e = to_left_comb_e_ true +let rec from_right_comb + (prev:expression) + (src_lmap: field_content label_map) + (dst_kvl:(label * field_content) list) + (conv_map:expression label_map) : expression label_map = + match dst_kvl with + | (label , {field_type;_}) :: (_::_ as tl) -> + let intermediary_type = LMap.find (Label "1") src_lmap in + let src_lmap' = match intermediary_type.field_type.type_content with + | T_record a -> a + | _ -> src_lmap in + let conv_map' = LMap.add label (accessor prev (Label "0") field_type) conv_map in + let next = accessor prev (Label "1") intermediary_type.field_type in + from_right_comb next src_lmap' tl conv_map' + | [(label,_)] -> LMap.add label prev conv_map + | [] -> conv_map -let to_sorted_kv_list (l_e:expression_label_map) (l_t:te_lmap) : (label * expression) list = - let l = List.combine (LMap.to_kv_list l_e) (LMap.to_kv_list l_t) in - let sorted' = List.sort - (fun (_,(_,{decl_position=a;_})) (_,(_,{decl_position=b;_})) -> Int.compare a b) l in - List.map (fun (e,_t) -> e) sorted' +let rec from_left_comb' + (prev:expression) + (src_lmap: field_content label_map) + (dst_kvl:(label * field_content) list) + (conv_map:expression label_map) : expression label_map = + match dst_kvl with + | (label , {field_type;_}) :: (_::_ as tl) -> + let intermediary_type = LMap.find (Label "0") src_lmap in + let src_lmap' = match intermediary_type.field_type.type_content with + | T_record a -> a + | _ -> src_lmap in + let conv_map' = LMap.add label (accessor prev (Label "1") field_type) conv_map in + let next = accessor prev (Label "0") intermediary_type.field_type in + from_left_comb' next src_lmap' tl conv_map' + | [(label,_)] -> LMap.add label prev conv_map + | [] -> conv_map +let from_left_comb prev src_lmap dst_kvl conv_map = + from_left_comb' prev src_lmap (List.rev dst_kvl) conv_map + +(** + converts pair/record of a given layout to record/pair to another + - foo = (a,(b,(c,d))) -> foo_converted = { a=foo.0 ; b=foo.1.0 ; c=foo.1.1.0 ; d=foo.1.1.1 } +**) let peephole_expression : expression -> expression result = fun e -> let return expression_content = ok { e with expression_content } in match e.expression_content with - | E_constant {cons_name= (C_CONVERT_TO_RIGHT_COMB | C_CONVERT_TO_LEFT_COMB ) as converter; - arguments= [ { - expression_content = record_exp; - type_expression = {type_content = T_record lmap_t} } - ] } -> - - let%bind lmap_e = match record_exp with - | E_record lmap_e -> ok lmap_e - | E_variable v -> get_label_map_from_env v e.environment - | _ -> simple_fail "corner case" in - - let kvl = to_sorted_kv_list lmap_e lmap_t in - let converted_exp = match converter with - | C_CONVERT_TO_RIGHT_COMB -> E_record (to_right_comb_e kvl LMap.empty) - | C_CONVERT_TO_LEFT_COMB -> E_record (to_left_comb_e kvl LMap.empty) - | _ -> e.expression_content - in - - return converted_exp - | _ as e -> return e \ No newline at end of file + | E_constant {cons_name= (C_CONVERT_TO_LEFT_COMB); + arguments= [ to_convert ] } -> + let%bind src_lmap = get_t_record to_convert.type_expression in + let src_kvl = to_sorted_kv_list src_lmap in + return @@ E_record (to_left_comb to_convert src_kvl LMap.empty) + | E_constant {cons_name= (C_CONVERT_TO_RIGHT_COMB); + arguments= [ to_convert ] } -> + let%bind src_lmap = get_t_record to_convert.type_expression in + let src_kvl = to_sorted_kv_list src_lmap in + return @@ E_record (to_right_comb to_convert src_kvl LMap.empty) + | E_constant {cons_name= (C_CONVERT_FROM_RIGHT_COMB); + arguments= [ to_convert ] } -> + let%bind dst_lmap = get_t_record e.type_expression in + let%bind src_lmap = get_t_record to_convert.type_expression in + let dst_kvl = to_sorted_kv_list dst_lmap in + return @@ E_record (from_right_comb to_convert src_lmap dst_kvl LMap.empty) + | E_constant {cons_name= (C_CONVERT_FROM_LEFT_COMB); + arguments= [ to_convert ] } -> + let%bind dst_lmap = get_t_record e.type_expression in + let%bind src_lmap = get_t_record to_convert.type_expression in + let dst_kvl = to_sorted_kv_list dst_lmap in + return @@ E_record (from_left_comb to_convert src_lmap dst_kvl LMap.empty) + | _ as e -> return e diff --git a/src/passes/operators/helpers.ml b/src/passes/operators/helpers.ml index a062aa36a..08c9f7b8b 100644 --- a/src/passes/operators/helpers.ml +++ b/src/passes/operators/helpers.ml @@ -135,6 +135,7 @@ module Typer = struct module Converter = struct open Ast_typed + open Trace let record_checks kvl = let%bind () = Assert.assert_true_err @@ -167,21 +168,20 @@ module Typer = struct let new_map' = LMap.add (Label "0") (annotate_field field ann) new_map in LMap.add (Label "1") (comb (T_record (to_right_comb_t tl new_map'))) new_map' - let rec to_left_comb_t_ first l new_map = + let rec to_left_comb_t' first l new_map = match l with | [] -> new_map | (Label ann_l, field_content_l) :: (Label ann_r, field_content_r) ::tl when first -> let new_map' = LMap.add_bindings [ (Label "0" , annotate_field field_content_l ann_l) ; (Label "1" , annotate_field field_content_r ann_r) ] LMap.empty in - to_left_comb_t_ false tl new_map' + to_left_comb_t' false tl new_map' | (Label ann, field)::tl -> let new_map' = LMap.add_bindings [ (Label "0" , comb (T_record new_map)) ; (Label "1" , annotate_field field ann ) ;] LMap.empty in - to_left_comb_t_ first tl new_map' - - let to_left_comb_t = to_left_comb_t_ true + to_left_comb_t' first tl new_map' + let to_left_comb_t = to_left_comb_t' true let convert_type_to_right_comb l = let l' = List.sort (fun (_,{decl_position=a;_}) (_,{decl_position=b;_}) -> Int.compare a b) l in @@ -190,6 +190,41 @@ module Typer = struct let convert_type_to_left_comb l = let l' = List.sort (fun (_,{decl_position=a;_}) (_,{decl_position=b;_}) -> Int.compare a b) l in T_record (to_left_comb_t l' LMap.empty) + + let rec from_right_comb (l:field_content label_map) (size:int) : (field_content list) result = + let l' = List.rev @@ LMap.to_kv_list l in + match l' , size with + | [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ] + | [ (_,l) ; (_,{field_type=tr;_}) ], _ -> + let%bind comb_lmap = get_t_record tr in + let%bind next = from_right_comb comb_lmap (size-1) in + ok (l :: next) + | _ -> simple_fail "Could not convert michelson_right_comb pair to a record" + + let rec from_left_comb (l:field_content label_map) (size:int) : (field_content list) result = + let l' = List.rev @@ LMap.to_kv_list l in + match l' , size with + | [ (_,l) ; (_,r) ] , 2 -> ok [ l ; r ] + | [ (_,{field_type=tl;_}) ; (_,r) ], _ -> + let%bind comb_lmap = get_t_record tl in + let%bind next = from_left_comb comb_lmap (size-1) in + ok (List.append next [r]) + | _ -> simple_fail "Could not convert michelson_left_comb pair to a record" + + let convert_from_right_comb (src: field_content label_map) (dst: field_content label_map) : type_content result = + let%bind fields = from_right_comb src (LMap.cardinal dst) in + let labels = List.map (fun (l,_) -> l) @@ + List.sort (fun (_,{decl_position=a;_}) (_,{decl_position=b;_}) -> Int.compare a b ) @@ + LMap.to_kv_list dst in + ok @@ (T_record (LMap.of_list @@ List.combine labels fields)) + + let convert_from_left_comb (src: field_content label_map) (dst: field_content label_map) : type_content result = + let%bind fields = from_left_comb src (LMap.cardinal dst) in + let labels = List.map (fun (l,_) -> l) @@ + List.sort (fun (_,{decl_position=a;_}) (_,{decl_position=b;_}) -> Int.compare a b ) @@ + LMap.to_kv_list dst in + ok @@ (T_record (LMap.of_list @@ List.combine labels fields)) + end end diff --git a/src/passes/operators/helpers.mli b/src/passes/operators/helpers.mli index faba8fe85..703fe9953 100644 --- a/src/passes/operators/helpers.mli +++ b/src/passes/operators/helpers.mli @@ -60,6 +60,8 @@ module Typer : sig val record_checks : (label * field_content) list -> unit result val convert_type_to_right_comb : (label * field_content) list -> type_content val convert_type_to_left_comb : (label * field_content) list -> type_content + val convert_from_right_comb : field_content label_map -> field_content label_map -> type_content result + val convert_from_left_comb : field_content label_map -> field_content label_map -> type_content result end end diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index e49d5c498..3eb629da9 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -161,7 +161,8 @@ module Concrete_to_imperative = struct | "Layout.convert_to_right_comb" -> Some C_CONVERT_TO_RIGHT_COMB | "Layout.convert_to_left_comb" -> Some C_CONVERT_TO_LEFT_COMB - (* | "Layout.convert_from" -> Some C_CONVERT_FROM *) + | "Layout.convert_from_right_comb" -> Some C_CONVERT_FROM_RIGHT_COMB + | "Layout.convert_from_left_comb" -> Some C_CONVERT_FROM_LEFT_COMB | _ -> None @@ -603,7 +604,7 @@ module Typer = struct | C_SELF_ADDRESS -> ok @@ t_self_address; | C_IMPLICIT_ACCOUNT -> ok @@ t_implicit_account; | C_SET_DELEGATE -> ok @@ t_set_delegate ; - | c -> simple_fail @@ Format.asprintf "Typer not implemented for consant %a" Ast_typed.PP.constant c + | c -> simple_fail @@ Format.asprintf "Typer not implemented for constant %a" Ast_typed.PP.constant c end let none = typer_0 "NONE" @@ fun tv_opt -> @@ -1180,6 +1181,20 @@ module Typer = struct let%bind () = Converter.record_checks kvl in let pair = Converter.convert_type_to_left_comb kvl in ok {record with type_content = pair} + + let convert_from_right_comb = typer_1_opt "CONVERT_FROM_RIGHT_COMB" @@ fun pair opt -> + let%bind dst_t = trace_option (simple_error "convert_from_right_comb must be annotated") opt in + let%bind dst_lmap = get_t_record dst_t in + let%bind src_lmap = get_t_record pair in + let%bind record = Converter.convert_from_right_comb src_lmap dst_lmap in + ok {pair with type_content = record} + + let convert_from_left_comb = typer_1_opt "CONVERT_FROM_LEFT_COMB" @@ fun pair opt -> + let%bind dst_t = trace_option (simple_error "convert_from_left_comb must be annotated") opt in + let%bind dst_lmap = get_t_record dst_t in + let%bind src_lmap = get_t_record pair in + let%bind record = Converter.convert_from_left_comb src_lmap dst_lmap in + ok {pair with type_content = record} let constant_typers c : typer result = match c with | C_INT -> ok @@ int ; @@ -1275,7 +1290,9 @@ module Typer = struct | C_CREATE_CONTRACT -> ok @@ create_contract ; | C_CONVERT_TO_RIGHT_COMB -> ok @@ convert_to_right_comb ; | C_CONVERT_TO_LEFT_COMB -> ok @@ convert_to_left_comb ; - | _ -> simple_fail @@ Format.asprintf "Typer not implemented for consant %a" PP.constant c + | C_CONVERT_FROM_RIGHT_COMB -> ok @@ convert_from_right_comb ; + | C_CONVERT_FROM_LEFT_COMB -> ok @@ convert_from_left_comb ; + | _ -> simple_fail @@ Format.asprintf "Typer not implemented for constant %a" PP.constant c diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index 9030d05f2..23c2e3b01 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -177,6 +177,8 @@ let constant ppf : constant' -> unit = function | C_CREATE_CONTRACT -> fprintf ppf "CREATE_CONTRACT" | C_CONVERT_TO_RIGHT_COMB -> fprintf ppf "CONVERT_TO_RIGHT_COMB" | C_CONVERT_TO_LEFT_COMB -> fprintf ppf "CONVERT_TO_LEFT_COMB" + | C_CONVERT_FROM_RIGHT_COMB -> fprintf ppf "CONVERT_FROM_RIGHT_COMB" + | C_CONVERT_FROM_LEFT_COMB -> fprintf ppf "CONVERT_FROM_LEFT_COMB" let literal ppf (l : literal) = match l with diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index 3f2871f66..c293e6dde 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -257,6 +257,8 @@ and constant' = | C_CREATE_CONTRACT | C_CONVERT_TO_LEFT_COMB | C_CONVERT_TO_RIGHT_COMB + | C_CONVERT_FROM_LEFT_COMB + | C_CONVERT_FROM_RIGHT_COMB and declaration_loc = declaration location_wrap diff --git a/src/stages/5-mini_c/PP.ml b/src/stages/5-mini_c/PP.ml index dd9aaae79..b06a312fd 100644 --- a/src/stages/5-mini_c/PP.ml +++ b/src/stages/5-mini_c/PP.ml @@ -250,6 +250,8 @@ and constant ppf : constant' -> unit = function | C_CREATE_CONTRACT -> fprintf ppf "CREATE_CONTRACT" | C_CONVERT_TO_RIGHT_COMB -> fprintf ppf "CONVERT_TO_RIGHT_COMB" | C_CONVERT_TO_LEFT_COMB -> fprintf ppf "CONVERT_TO_LEFT_COMB" + | C_CONVERT_FROM_RIGHT_COMB -> fprintf ppf "CONVERT_FROM_RIGHT_COMB" + | C_CONVERT_FROM_LEFT_COMB -> fprintf ppf "CONVERT_FROM_LEFT_COMB" let%expect_test _ = Format.printf "%a" value (D_bytes (Bytes.of_string "foo")) ; diff --git a/src/stages/common/PP.ml b/src/stages/common/PP.ml index 700d62576..b35efeb8f 100644 --- a/src/stages/common/PP.ml +++ b/src/stages/common/PP.ml @@ -127,6 +127,8 @@ let constant ppf : constant' -> unit = function | C_CREATE_CONTRACT -> fprintf ppf "CREATE_CONTRACT" | C_CONVERT_TO_RIGHT_COMB -> fprintf ppf "CONVERT_TO_RIGHT_COMB" | C_CONVERT_TO_LEFT_COMB -> fprintf ppf "CONVERT_TO_LEFT_COMB" + | C_CONVERT_FROM_RIGHT_COMB -> fprintf ppf "CONVERT_FROM_RIGHT_COMB" + | C_CONVERT_FROM_LEFT_COMB -> fprintf ppf "CONVERT_FROM_LEFT_COMB" let literal ppf (l : literal) = match l with diff --git a/src/stages/common/types.ml b/src/stages/common/types.ml index 10788b140..a91566f69 100644 --- a/src/stages/common/types.ml +++ b/src/stages/common/types.ml @@ -306,3 +306,5 @@ and constant' = | C_CREATE_CONTRACT | C_CONVERT_TO_LEFT_COMB | C_CONVERT_TO_RIGHT_COMB + | C_CONVERT_FROM_LEFT_COMB + | C_CONVERT_FROM_RIGHT_COMB diff --git a/src/test/contracts/michelson_converter.mligo b/src/test/contracts/michelson_converter.mligo index ea9aaa93d..064de13f9 100644 --- a/src/test/contracts/michelson_converter.mligo +++ b/src/test/contracts/michelson_converter.mligo @@ -1,11 +1,29 @@ type t3 = { foo : int ; bar : nat ; baz : string} -let v3 = { foo = 2 ; bar = 3n ; baz = "q" } - type t4 = { one: int ; two : nat ; three : string ; four : bool} -let v4 = { one = 2 ; two = 3n ; three = "q" ; four = true } + +(*convert to*) + +let v3 = { foo = 2 ; bar = 3n ; baz = "q" } let r3 = Layout.convert_to_right_comb (v3:t3) +let v4 = { one = 2 ; two = 3n ; three = "q" ; four = true } let r4 = Layout.convert_to_right_comb (v4:t4) let l3 = Layout.convert_to_left_comb (v3:t3) -let l4 = Layout.convert_to_left_comb (v4:t4) \ No newline at end of file +let l4 = Layout.convert_to_left_comb (v4:t4) + +(*convert from*) + +let s = "eq" +let test_input_pair_r = (1,(2n,(s,true))) +let test_input_pair_l = (((1,2n), s), true) +type param_r = t4 michelson_right_comb +type param_l = t4 michelson_left_comb + +let main_r (p, s : param_r * string) : (operation list * string) = + let r4 : t4 = Layout.convert_from_right_comb p in + ([] : operation list), r4.three ^ p.1.1.0 + +let main_l (p, s : param_l * string) : (operation list * string) = + let r4 : t4 = Layout.convert_from_left_comb p in + ([] : operation list), r4.three ^ p.0.1 \ No newline at end of file