From 8e3230bf2934bb2290be22e3fa20849e7fabadb4 Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Wed, 29 Apr 2020 23:17:29 +0200 Subject: [PATCH] 'Layout.convert_to_right_comb' and 'Layout.convert_to_left_comb' for sum types --- src/bin/expect_tests/michelson_converter.ml | 32 ++-- .../2-concrete_to_imperative/cameligo.ml | 8 +- .../2-concrete_to_imperative/pascaligo.ml | 8 +- src/passes/3-self_ast_imperative/helpers.ml | 9 +- .../imperative_to_sugar.ml | 12 +- src/passes/6-sugar_to_core/sugar_to_core.ml | 8 +- src/passes/8-typer-new/typer.ml | 4 +- src/passes/8-typer-new/untyper.ml | 4 +- src/passes/8-typer-old/typer.ml | 8 +- .../9-self_ast_typed/michelson_layout.ml | 138 +++++++++++++++--- src/passes/operators/helpers.ml | 102 ++++++++++--- src/passes/operators/helpers.mli | 13 +- src/passes/operators/operators.ml | 42 ++++-- src/passes/operators/operators.mli | 4 +- src/stages/1-ast_imperative/PP.ml | 4 +- src/stages/1-ast_imperative/combinators.ml | 8 +- src/stages/1-ast_imperative/types.ml | 6 +- src/stages/2-ast_sugar/types.ml | 2 +- src/stages/4-ast_typed/types.ml | 1 + src/stages/common/types.ml | 2 +- .../contracts/michelson_converter_or.mligo | 21 +++ ...r.mligo => michelson_converter_pair.mligo} | 10 +- src/test/typer_tests.ml | 4 +- 23 files changed, 330 insertions(+), 120 deletions(-) create mode 100644 src/test/contracts/michelson_converter_or.mligo rename src/test/contracts/{michelson_converter.mligo => michelson_converter_pair.mligo} (95%) diff --git a/src/bin/expect_tests/michelson_converter.ml b/src/bin/expect_tests/michelson_converter.ml index 81b0d9fc9..e477b0f63 100644 --- a/src/bin/expect_tests/michelson_converter.ml +++ b/src/bin/expect_tests/michelson_converter.ml @@ -8,7 +8,7 @@ let bad_contract basename = let%expect_test _ = run_ligo_bad [ "interpret" ; "--init-file="^(bad_contract "michelson_converter_no_annotation.mligo") ; "l4"] ; [%expect {| - ligo: in file "michelson_converter_no_annotation.mligo", line 4, characters 9-39. can't retrieve declaration order in the converted record, you need to annotate it + ligo: in file "michelson_converter_no_annotation.mligo", line 4, characters 9-39. can't retrieve type declaration order in the converted record, you need to annotate it If you're not sure how to fix this error, you can do one of the following: @@ -31,24 +31,36 @@ let%expect_test _ = * Check the changelog by running 'ligo changelog' |}] let%expect_test _ = - run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "r3"] ; + run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_pair.mligo") ; "r3"] ; [%expect {| ( 2 , ( +3 , "q" ) ) |}] ; - run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "r4"] ; + run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_pair.mligo") ; "r4"] ; [%expect {| ( 2 , ( +3 , ( "q" , true ) ) ) |}] ; - run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "l3"] ; + run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_pair.mligo") ; "l3"] ; [%expect {| ( ( 2 , +3 ) , "q" ) |}] ; - run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "l4"] ; + run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_pair.mligo") ; "l4"] ; [%expect {| - ( ( ( 2 , +3 ) , "q" ) , true ) |}] + ( ( ( 2 , +3 ) , "q" ) , true ) |}]; + run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_or.mligo") ; "str3"] ; + [%expect {| + M_right(M_left(+3)) |}] ; + run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_or.mligo") ; "str4"] ; + [%expect {| + M_right(M_right(M_left("eq"))) |}] ; + run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_or.mligo") ; "stl3"] ; + [%expect {| + M_left(M_right(+3)) |}] ; + run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter_or.mligo") ; "stl4"] ; + [%expect {| + M_left(M_right("eq")) |}] let%expect_test _ = - run_ligo_good [ "dry-run" ; (contract "michelson_converter.mligo") ; "main_r" ; "test_input_pair_r" ; "s"] ; + run_ligo_good [ "dry-run" ; (contract "michelson_converter_pair.mligo") ; "main_r" ; "test_input_pair_r" ; "s"] ; [%expect {| ( LIST_EMPTY() , "eqeq" ) |}] ; - run_ligo_good [ "compile-contract" ; (contract "michelson_converter.mligo") ; "main_r" ] ; + run_ligo_good [ "compile-contract" ; (contract "michelson_converter_pair.mligo") ; "main_r" ] ; [%expect {| { parameter (pair (int %one) (pair (nat %two) (pair (string %three) (bool %four)))) ; storage string ; @@ -68,10 +80,10 @@ let%expect_test _ = NIL operation ; PAIR ; DIP { DROP 2 } } } |}]; - run_ligo_good [ "dry-run" ; (contract "michelson_converter.mligo") ; "main_l" ; "test_input_pair_l" ; "s"] ; + run_ligo_good [ "dry-run" ; (contract "michelson_converter_pair.mligo") ; "main_l" ; "test_input_pair_l" ; "s"] ; [%expect {| ( LIST_EMPTY() , "eqeq" ) |}] ; - run_ligo_good [ "compile-contract" ; (contract "michelson_converter.mligo") ; "main_l" ] ; + run_ligo_good [ "compile-contract" ; (contract "michelson_converter_pair.mligo") ; "main_l" ] ; [%expect {| { parameter (pair (pair (pair (int %one) (nat %two)) (string %three)) (bool %four)) ; storage string ; diff --git a/src/passes/2-concrete_to_imperative/cameligo.ml b/src/passes/2-concrete_to_imperative/cameligo.ml index f688d0d10..11a714460 100644 --- a/src/passes/2-concrete_to_imperative/cameligo.ml +++ b/src/passes/2-concrete_to_imperative/cameligo.ml @@ -307,18 +307,18 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te - ok @@ make_t ~loc @@ T_record m | TSum s -> let (s,loc) = r_split s in - let aux (v:Raw.variant Raw.reg) = + let aux i (v:Raw.variant Raw.reg) = let args = match v.value.arg with None -> [] | Some (_, TProd product) -> npseq_to_list product.value | Some (_, t_expr) -> [t_expr] in let%bind te = compile_list_type_expression @@ args in - ok (v.value.constr.value, te) in + ok ((v.value.constr.value,i), te) in let%bind lst = bind_list - @@ List.map aux + @@ List.mapi aux @@ npseq_to_list s in - let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in + let m = List.fold_left (fun m ((x,i), y) -> CMap.add (Constructor x) {ctor_type=y;ctor_decl_pos=i} m) CMap.empty lst in ok @@ make_t ~loc @@ T_sum m | TStringLiteral _s -> simple_fail "we don't support singleton string type" diff --git a/src/passes/2-concrete_to_imperative/pascaligo.ml b/src/passes/2-concrete_to_imperative/pascaligo.ml index 343ed06ad..9d27ec0bc 100644 --- a/src/passes/2-concrete_to_imperative/pascaligo.ml +++ b/src/passes/2-concrete_to_imperative/pascaligo.ml @@ -238,19 +238,19 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result = ok @@ make_t ~loc @@ T_record m | TSum s -> let (s,loc) = r_split s in - let aux (v:Raw.variant Raw.reg) = + let aux i (v:Raw.variant Raw.reg) = let args = match v.value.arg with None -> [] | Some (_, TProd product) -> npseq_to_list product.value | Some (_, t_expr) -> [t_expr] in let%bind te = compile_list_type_expression @@ args in - ok (v.value.constr.value, te) + ok ((v.value.constr.value,i), te) in let%bind lst = bind_list - @@ List.map aux + @@ List.mapi aux @@ npseq_to_list s in - let m = List.fold_left (fun m (x, y) -> CMap.add (Constructor x) y m) CMap.empty lst in + let m = List.fold_left (fun m ((x,i), y) -> CMap.add (Constructor x) {ctor_type=y;ctor_decl_pos=i} m) CMap.empty lst in ok @@ make_t ~loc @@ T_sum m | TStringLiteral _s -> simple_fail "we don't support singleton string type" diff --git a/src/passes/3-self_ast_imperative/helpers.ml b/src/passes/3-self_ast_imperative/helpers.ml index 557243f98..e08e1ef53 100644 --- a/src/passes/3-self_ast_imperative/helpers.ml +++ b/src/passes/3-self_ast_imperative/helpers.ml @@ -2,6 +2,13 @@ open Ast_imperative open Trace open Stage_common.Helpers +let bind_map_cmap_t f map = bind_cmap ( + CMap.map + (fun ({ctor_type;_} as ctor) -> + let%bind ctor_type = f ctor_type in + ok {ctor with ctor_type }) + map) + let bind_map_lmap_t f map = bind_lmap ( LMap.map (fun ({field_type;_} as field) -> @@ -257,7 +264,7 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re let return type_content = ok { type_content; location=te.location } in match te'.type_content with | T_sum temap -> - let%bind temap' = bind_map_cmap self temap in + let%bind temap' = bind_map_cmap_t self temap in return @@ (T_sum temap') | T_record temap -> let%bind temap' = bind_map_lmap_t self temap in diff --git a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml index 44f498807..8e8036101 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -135,9 +135,9 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result | I.T_sum sum -> let sum = I.CMap.to_kv_list sum in let%bind sum = - bind_map_list (fun (k,v) -> + bind_map_list (fun (k,({ctor_type = v; ctor_decl_pos ; _}:I.ctor_content)) -> let%bind v = compile_type_expression v in - let content : O.ctor_content = {ctor_type = v ; michelson_annotation = None} in + let content : O.ctor_content = {ctor_type = v ; michelson_annotation = None ; ctor_decl_pos } in ok @@ (k,content) ) sum in @@ -164,8 +164,8 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result | I.T_operator (TC_michelson_or (l,l_ann,r,r_ann)) -> let%bind (l,r) = bind_map_pair compile_type_expression (l,r) in let sum : (O.constructor' * O.ctor_content) list = [ - (O.Constructor "M_left" , {ctor_type = l ; michelson_annotation = Some l_ann}); - (O.Constructor "M_right", {ctor_type = r ; michelson_annotation = Some r_ann}); ] + (O.Constructor "M_left" , {ctor_type = l ; michelson_annotation = Some l_ann ; ctor_decl_pos = 0}); + (O.Constructor "M_right", {ctor_type = r ; michelson_annotation = Some r_ann ; ctor_decl_pos = 1}); ] in return @@ O.T_sum (O.CMap.of_list sum) | I.T_operator (TC_michelson_pair (l,l_ann,r,r_ann)) -> @@ -596,9 +596,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul let sum = I.CMap.to_kv_list sum in let%bind sum = bind_map_list (fun (k,v) -> - let {ctor_type;_} : O.ctor_content = v in + let {ctor_type;ctor_decl_pos;_} : O.ctor_content = v in let%bind v = uncompile_type_expression ctor_type in - ok @@ (k,v) + ok @@ (k,({ctor_type=v; ctor_decl_pos}: I.ctor_content)) ) sum in return @@ I.T_sum (O.CMap.of_list sum) diff --git a/src/passes/6-sugar_to_core/sugar_to_core.ml b/src/passes/6-sugar_to_core/sugar_to_core.ml index 6d2a4de47..972a26e9d 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -10,9 +10,9 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result = let sum = I.CMap.to_kv_list sum in let%bind sum = bind_map_list (fun (k,v) -> - let {ctor_type ; michelson_annotation} : I.ctor_content = v in + let {ctor_type ; michelson_annotation ; ctor_decl_pos} : I.ctor_content = v in let%bind ctor_type = idle_type_expression ctor_type in - let v' : O.ctor_content = {ctor_type ; michelson_annotation} in + let v' : O.ctor_content = {ctor_type ; michelson_annotation ; ctor_decl_pos} in ok @@ (k,v') ) sum in @@ -244,9 +244,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul let sum = I.CMap.to_kv_list sum in let%bind sum = bind_map_list (fun (k,v) -> - let {ctor_type;michelson_annotation} : O.ctor_content = v in + let {ctor_type;michelson_annotation;ctor_decl_pos} : O.ctor_content = v in let%bind ctor_type = uncompile_type_expression ctor_type in - let v' : I.ctor_content = {ctor_type;michelson_annotation} in + let v' : I.ctor_content = {ctor_type;michelson_annotation;ctor_decl_pos} in ok @@ (k,v') ) sum in diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 309d0b81b..31c0f7a83 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -133,9 +133,9 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu | T_sum m -> let aux k v prev = let%bind prev' = prev in - let {ctor_type ; michelson_annotation} : I.ctor_content = v in + let {ctor_type ; michelson_annotation ; ctor_decl_pos} : I.ctor_content = v in let%bind ctor_type = evaluate_type e ctor_type in - ok @@ O.CMap.add (convert_constructor' k) ({ctor_type ; michelson_annotation}:O.ctor_content) prev' + ok @@ O.CMap.add (convert_constructor' k) ({ctor_type ; michelson_annotation ; ctor_decl_pos}:O.ctor_content) prev' in let%bind m = I.CMap.fold aux m (ok O.CMap.empty) in return (T_sum m) diff --git a/src/passes/8-typer-new/untyper.ml b/src/passes/8-typer-new/untyper.ml index 10e719c9a..22bab7ba7 100644 --- a/src/passes/8-typer-new/untyper.ml +++ b/src/passes/8-typer-new/untyper.ml @@ -152,10 +152,10 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul (* TODO: or should we use t.core if present? *) let%bind t = match t.type_content with | O.T_sum x -> - let aux k ({ctor_type ; michelson_annotation} : O.ctor_content) acc = + let aux k ({ctor_type ; michelson_annotation ; ctor_decl_pos} : O.ctor_content) acc = let%bind acc = acc in let%bind ctor_type = untype_type_expression ctor_type in - let v' : I.ctor_content = {ctor_type ; michelson_annotation} in + let v' : I.ctor_content = {ctor_type ; michelson_annotation ; ctor_decl_pos} in ok @@ I.CMap.add (unconvert_constructor' k) v' acc in let%bind x' = O.CMap.fold aux x (ok I.CMap.empty) in ok @@ I.T_sum x' diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index 90e73ce12..b359cfed0 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -605,7 +605,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu let%bind type2 = evaluate_type e type2 in return (T_arrow {type1;type2}) | T_sum m -> - let aux k ({ctor_type;michelson_annotation} : I.ctor_content) prev = + let aux k ({ctor_type;michelson_annotation;ctor_decl_pos} : I.ctor_content) prev = let%bind prev' = prev in let%bind ctor_type = evaluate_type e ctor_type in let%bind () = match Environment.get_constructor k e with @@ -614,7 +614,7 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu ok () else fail (redundant_constructor e k) | None -> ok () in - let v' : O.ctor_content = {ctor_type;michelson_annotation} in + let v' : O.ctor_content = {ctor_type;michelson_annotation;ctor_decl_pos} in ok @@ O.CMap.add (convert_constructor' k) v' prev' in let%bind m = I.CMap.fold aux m (ok O.CMap.empty) in @@ -665,14 +665,14 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu let%bind lmap = match c'.type_content with | T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap | _ -> fail (michelson_comb_no_record t.location) in - let record = Operators.Typer.Converter.convert_type_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in + let record = Operators.Typer.Converter.convert_pair_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in return @@ record | TC_michelson_pair_left_comb c -> let%bind c' = evaluate_type e c in let%bind lmap = match c'.type_content with | T_record lmap when (not (Ast_typed.Helpers.is_tuple_lmap lmap)) -> ok lmap | _ -> fail (michelson_comb_no_record t.location) in - let record = Operators.Typer.Converter.convert_type_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in + let record = Operators.Typer.Converter.convert_pair_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in return @@ record ) diff --git a/src/passes/9-self_ast_typed/michelson_layout.ml b/src/passes/9-self_ast_typed/michelson_layout.ml index 43a120dcf..efd0584be 100644 --- a/src/passes/9-self_ast_typed/michelson_layout.ml +++ b/src/passes/9-self_ast_typed/michelson_layout.ml @@ -1,34 +1,99 @@ open Ast_typed open Trace -let to_sorted_kv_list lmap = +let to_sorted_kv_list_l lmap = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;}) -> Int.compare a b) @@ LMap.to_kv_list lmap +let to_sorted_kv_list_c lmap = + List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;}) -> Int.compare a b) @@ + CMap.to_kv_list lmap + 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} + environment = record.environment } -let rec to_left_comb' first prev l conv_map = +let constructor (constructor:constructor') (element:expression) (t:type_expression) = + { expression_content = E_constructor { constructor ; element } ; + location = Location.generated ; + type_expression = t ; + environment = element.environment } + +let match_var env (t:type_expression) = + { expression_content = E_variable (Var.of_name "x") ; + location = Location.generated ; + type_expression = t ; + environment = env } + +let rec to_left_comb_record' first prev l conv_map = match l with | [] -> 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' + to_left_comb_record' 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' + to_left_comb_record' first prev tl conv_map' +let to_left_comb_record = to_left_comb_record' true -let to_left_comb = to_left_comb' true +let rec to_right_comb_variant' (i:int) (e:expression) (dst_lmap:ctor_content constructor_map) (src_kvl:(constructor' * ctor_content) list) : expression list = + let rec descend_types lmap i = + if i > 0 then + let {ctor_type;_} = CMap.find (Constructor "M_right") lmap in + match ctor_type.type_content with + | T_sum a -> ctor_type::(descend_types a (i-1)) + | _ -> [] + else [] in + let intermediary_types i = if i = 0 then [] else e.type_expression::(descend_types dst_lmap i) in + let rec comb (ctor_type,outer) l = + let env' = Environment.add_ez_binder (Var.of_name "x") ctor_type e.environment in + match l with + | [] -> constructor outer (match_var env' ctor_type) e.type_expression + | [t] -> constructor outer (match_var env' ctor_type) t + | t::tl -> constructor (Constructor "M_right") (comb (ctor_type,outer) tl) t in + ( match src_kvl with + | [] -> [] + | (_,{ctor_type;_})::[] -> + let combs_t = intermediary_types (i-1) in + [comb (ctor_type,Constructor "M_right") combs_t] + | (_,{ctor_type;_})::tl -> + let combs_t = intermediary_types i in + (comb (ctor_type,Constructor "M_left") combs_t) :: to_right_comb_variant' (i+1) e dst_lmap tl ) +let to_right_comb_variant = to_right_comb_variant' 0 -let rec to_right_comb +let rec to_left_comb_variant' (i:int) (e:expression) (dst_lmap:ctor_content constructor_map) (src_kvl:(constructor' * ctor_content) list) : expression list = + let rec descend_types lmap i = + if i > 0 then + let {ctor_type;_} = CMap.find (Constructor "M_left") lmap in + match ctor_type.type_content with + | T_sum a -> ctor_type::(descend_types a (i-1)) + | _ -> [] + else [] in + let intermediary_types i = if i = 0 then [] else e.type_expression::(descend_types dst_lmap i) in + let rec comb (ctor_type,outer) l = + let env' = Environment.add_ez_binder (Var.of_name "x") ctor_type e.environment in + match l with + | [] -> constructor outer (match_var env' ctor_type) e.type_expression + | [t] -> constructor outer (match_var env' ctor_type) t + | t::tl -> constructor (Constructor "M_left") (comb (ctor_type,outer) tl) t in + ( match src_kvl with + | [] -> [] + | (_,{ctor_type;_})::[] -> + let combs_t = intermediary_types (i-1) in + [comb (ctor_type,Constructor "M_left") combs_t] + | (_,{ctor_type;_})::tl -> + let combs_t = intermediary_types i in + (comb (ctor_type,Constructor "M_right") combs_t) :: to_left_comb_variant' (i+1) e dst_lmap tl ) +let to_left_comb_variant a b c = List.rev @@ to_left_comb_variant' 0 a b (List.rev c) + +let rec to_right_comb_record (prev:expression) (l:(label * field_content) list) (conv_map: expression label_map) : expression label_map = @@ -44,7 +109,7 @@ let rec to_right_comb 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' + LMap.add (Label "1") ({exp with expression_content = E_record (to_right_comb_record prev tl conv_map')}) conv_map' let rec from_right_comb (prev:expression) @@ -79,7 +144,6 @@ let rec from_left_comb' 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 @@ -90,26 +154,56 @@ let from_left_comb prev src_lmap dst_kvl conv_map = 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_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_TO_LEFT_COMB);arguments= [ to_convert ] } -> ( + match to_convert.type_expression.type_content with + | T_record src_lmap -> + let src_kvl = to_sorted_kv_list_l src_lmap in + return @@ E_record (to_left_comb_record to_convert src_kvl LMap.empty) + | T_sum src_cmap -> + let%bind dst_cmap = get_t_sum e.type_expression in + let src_kvl = to_sorted_kv_list_c src_cmap in + let bodies = to_left_comb_variant e dst_cmap src_kvl in + let to_cases ((constructor,{ctor_type=_;_}),body) = + let pattern = (Var.of_name "x") in + {constructor ; pattern ; body } + in + let cases = Match_variant { + cases = List.map to_cases @@ (List.combine src_kvl bodies) ; + tv = to_convert.type_expression } + in + return @@ E_matching {matchee = to_convert ; cases} + | _ -> return e.expression_content + ) + | E_constant {cons_name= (C_CONVERT_TO_RIGHT_COMB);arguments= [ to_convert ] } -> ( + match to_convert.type_expression.type_content with + | T_record src_lmap -> + let src_kvl = to_sorted_kv_list_l src_lmap in + return @@ E_record (to_right_comb_record to_convert src_kvl LMap.empty) + | T_sum src_cmap -> + let%bind dst_cmap = get_t_sum e.type_expression in + let src_kvl = to_sorted_kv_list_c src_cmap in + let bodies = to_right_comb_variant e dst_cmap src_kvl in + let to_cases ((constructor,{ctor_type=_;_}),body) = + let pattern = (Var.of_name "x") in + {constructor ; pattern ; body } + in + let cases = Match_variant { + cases = List.map to_cases @@ (List.combine src_kvl bodies) ; + tv = to_convert.type_expression } + in + return @@ E_matching {matchee = to_convert ; cases} + | _ -> return e.expression_content + ) | 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 + let dst_kvl = to_sorted_kv_list_l 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 + let dst_kvl = to_sorted_kv_list_l dst_lmap in return @@ E_record (from_left_comb to_convert src_lmap dst_kvl LMap.empty) - | _ as e -> return e + | _ as e -> return e \ No newline at end of file diff --git a/src/passes/operators/helpers.ml b/src/passes/operators/helpers.ml index 988185692..826499ce9 100644 --- a/src/passes/operators/helpers.ml +++ b/src/passes/operators/helpers.ml @@ -143,21 +143,41 @@ module Typer = struct (List.length kvl >=2) in let all_undefined = List.for_all (fun (_,{field_decl_pos;_}) -> field_decl_pos = 0) kvl in let%bind () = Assert.assert_true_err - (simple_error "can't retrieve declaration order in the converted record, you need to annotate it") + (simple_error "can't retrieve type declaration order in the converted record, you need to annotate it") (not all_undefined) in ok () + let variant_checks kvl = + let%bind () = Assert.assert_true_err + (simple_error "converted variant must have at least two elements") + (List.length kvl >=2) in + let all_undefined = List.for_all (fun (_,{ctor_decl_pos;_}) -> ctor_decl_pos = 0) kvl in + let%bind () = Assert.assert_true_err + (simple_error "can't retrieve type declaration order in the converted variant, you need to annotate it") + (not all_undefined) in + ok () + let annotate_field (field:field_content) (ann:string) : field_content = {field with michelson_annotation=Some ann} - let comb (t:type_content) : field_content = + let annotate_ctor (ctor:ctor_content) (ann:string) : ctor_content = + {ctor with michelson_annotation=Some ann} + + let comb_pair (t:type_content) : field_content = let field_type = { type_content = t ; type_meta = None ; location = Location.generated ; } in {field_type ; michelson_annotation = Some "" ; field_decl_pos = 0} - let rec to_right_comb_t l new_map = + let comb_ctor (t:type_content) : ctor_content = + let ctor_type = { + type_content = t ; + type_meta = None ; + location = Location.generated ; } in + {ctor_type ; michelson_annotation = Some "" ; ctor_decl_pos = 0} + + let rec to_right_comb_pair l new_map = match l with | [] -> new_map | [ (Label ann_l, field_content_l) ; (Label ann_r, field_content_r) ] -> @@ -166,65 +186,99 @@ module Typer = struct (Label "1" , annotate_field field_content_r ann_r) ] new_map | (Label ann, field)::tl -> 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' + LMap.add (Label "1") (comb_pair (T_record (to_right_comb_pair tl new_map'))) new_map' - let rec to_left_comb_t' first l new_map = + let rec to_right_comb_variant l new_map = + match l with + | [] -> new_map + | [ (Constructor ann_l, field_content_l) ; (Constructor ann_r, field_content_r) ] -> + CMap.add_bindings [ + (Constructor "M_left" , annotate_ctor field_content_l ann_l) ; + (Constructor "M_right" , annotate_ctor field_content_r ann_r) ] new_map + | (Constructor ann, field)::tl -> + let new_map' = CMap.add (Constructor "M_left") (annotate_ctor field ann) new_map in + CMap.add (Constructor "M_right") (comb_ctor (T_sum (to_right_comb_variant tl new_map'))) new_map' + + let rec to_left_comb_pair' 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_pair' false tl new_map' | (Label ann, field)::tl -> let new_map' = LMap.add_bindings [ - (Label "0" , comb (T_record new_map)) ; + (Label "0" , comb_pair (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_pair' first tl new_map' + let to_left_comb_pair = to_left_comb_pair' true - let convert_type_to_right_comb l = - let l' = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b) l in - T_record (to_right_comb_t l' LMap.empty) + let rec to_left_comb_variant' first l new_map = + match l with + | [] -> new_map + | (Constructor ann_l, ctor_content_l) :: (Constructor ann_r, ctor_content_r) ::tl when first -> + let new_map' = CMap.add_bindings [ + (Constructor "M_left" , annotate_ctor ctor_content_l ann_l) ; + (Constructor "M_right" , annotate_ctor ctor_content_r ann_r) ] CMap.empty in + to_left_comb_variant' false tl new_map' + | (Constructor ann, ctor)::tl -> + let new_map' = CMap.add_bindings [ + (Constructor "M_left" , comb_ctor (T_sum new_map)) ; + (Constructor "M_right" , annotate_ctor ctor ann ) ;] CMap.empty in + to_left_comb_variant' first tl new_map' + let to_left_comb_variant = to_left_comb_variant' true - let convert_type_to_left_comb l = - let l' = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=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 rec from_right_comb_pair (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 + let%bind next = from_right_comb_pair comb_lmap (size-1) in ok (l :: next) | _ -> simple_fail "Could not convert michelson_pair_right_comb pair to a record" - let rec from_left_comb (l:field_content label_map) (size:int) : (field_content list) result = + let rec from_left_comb_pair (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 + let%bind next = from_left_comb_pair comb_lmap (size-1) in ok (List.append next [r]) | _ -> simple_fail "Could not convert michelson_pair_left_comb pair to a record" + + let convert_pair_to_right_comb l = + let l' = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b) l in + T_record (to_right_comb_pair l' LMap.empty) + + let convert_pair_to_left_comb l = + let l' = List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b) l in + T_record (to_left_comb_pair l' LMap.empty) - 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 convert_pair_from_right_comb (src: field_content label_map) (dst: field_content label_map) : type_content result = + let%bind fields = from_right_comb_pair src (LMap.cardinal dst) in let labels = List.map (fun (l,_) -> l) @@ List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=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 convert_pair_from_left_comb (src: field_content label_map) (dst: field_content label_map) : type_content result = + let%bind fields = from_left_comb_pair src (LMap.cardinal dst) in let labels = List.map (fun (l,_) -> l) @@ List.sort (fun (_,{field_decl_pos=a;_}) (_,{field_decl_pos=b;_}) -> Int.compare a b ) @@ LMap.to_kv_list dst in ok @@ (T_record (LMap.of_list @@ List.combine labels fields)) + let convert_variant_to_right_comb l = + let l' = List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b) l in + T_sum (to_right_comb_variant l' CMap.empty) + + let convert_variant_to_left_comb l = + let l' = List.sort (fun (_,{ctor_decl_pos=a;_}) (_,{ctor_decl_pos=b;_}) -> Int.compare a b) l in + T_sum (to_left_comb_variant l' CMap.empty) + end end diff --git a/src/passes/operators/helpers.mli b/src/passes/operators/helpers.mli index 703fe9953..837705f0e 100644 --- a/src/passes/operators/helpers.mli +++ b/src/passes/operators/helpers.mli @@ -58,10 +58,15 @@ module Typer : sig open Ast_typed 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 + val variant_checks : (constructor' * ctor_content) list -> unit result + + val convert_pair_to_right_comb : (label * field_content) list -> type_content + val convert_pair_to_left_comb : (label * field_content) list -> type_content + val convert_pair_from_right_comb : field_content label_map -> field_content label_map -> type_content result + val convert_pair_from_left_comb : field_content label_map -> field_content label_map -> type_content result + + val convert_variant_to_right_comb : (constructor' * ctor_content) list -> type_content + val convert_variant_to_left_comb : (constructor' * ctor_content) list -> type_content end end diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index 582f5d1f4..046a300bc 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -1168,32 +1168,46 @@ module Typer = struct let%bind () = assert_eq_1 hd elt in ok tl - let convert_to_right_comb = typer_1 "CONVERT_TO_RIGHT_COMB" @@ fun record -> - let%bind lmap = get_t_record record in - let kvl = LMap.to_kv_list lmap in - let%bind () = Converter.record_checks kvl in - let pair = Converter.convert_type_to_right_comb kvl in - ok {record with type_content = pair} + let convert_to_right_comb = typer_1 "CONVERT_TO_RIGHT_COMB" @@ fun t -> + match t.type_content with + | T_record lmap -> + let kvl = LMap.to_kv_list lmap in + let%bind () = Converter.record_checks kvl in + let pair = Converter.convert_pair_to_right_comb kvl in + ok {t with type_content = pair} + | T_sum cmap -> + let kvl = CMap.to_kv_list cmap in + let%bind () = Converter.variant_checks kvl in + let michelson_or = Converter.convert_variant_to_right_comb kvl in + ok {t with type_content = michelson_or} + | _ -> simple_fail "converter can only be used on record or variants" - let convert_to_left_comb = typer_1 "CONVERT_TO_LEFT_COMB" @@ fun record -> - let%bind lmap = get_t_record record in - let kvl = LMap.to_kv_list lmap in - 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_to_left_comb = typer_1 "CONVERT_TO_LEFT_COMB" @@ fun t -> + match t.type_content with + | T_record lmap -> + let kvl = LMap.to_kv_list lmap in + let%bind () = Converter.record_checks kvl in + let pair = Converter.convert_pair_to_left_comb kvl in + ok {t with type_content = pair} + | T_sum cmap -> + let kvl = CMap.to_kv_list cmap in + let%bind () = Converter.variant_checks kvl in + let michelson_or = Converter.convert_variant_to_left_comb kvl in + ok {t with type_content = michelson_or} + | _ -> simple_fail "converter can only be used on record or variants" 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 + let%bind record = Converter.convert_pair_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 + let%bind record = Converter.convert_pair_from_left_comb src_lmap dst_lmap in ok {pair with type_content = record} let constant_typers c : typer result = match c with diff --git a/src/passes/operators/operators.mli b/src/passes/operators/operators.mli index d401deeed..5f5f62bb0 100644 --- a/src/passes/operators/operators.mli +++ b/src/passes/operators/operators.mli @@ -176,8 +176,8 @@ module Typer : sig open Ast_typed 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_pair_to_right_comb : (label * field_content) list -> type_content + val convert_pair_to_left_comb : (label * field_content) list -> type_content end end diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index 47c19ecba..02deff4b7 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -8,7 +8,7 @@ include Stage_common.PP let cmap_sep value sep ppf m = let lst = CMap.to_kv_list m in let lst = List.sort (fun (Constructor a,_) (Constructor b,_) -> String.compare a b) lst in - let new_pp ppf (k, v) = fprintf ppf "@[%a -> %a@]" constructor k value v in + let new_pp ppf (k, ({ctor_type=v;_}:ctor_content)) = fprintf ppf "@[%a -> %a@]" constructor k value v in fprintf ppf "%a" (list_sep new_pp sep) lst let cmap_sep_d x = cmap_sep x (tag " ,@ ") @@ -16,7 +16,7 @@ let cmap_sep_d x = cmap_sep x (tag " ,@ ") let record_sep_t value sep ppf (m : 'a label_map) = let lst = LMap.to_kv_list m in let lst = List.sort_uniq (fun (Label a,_) (Label b,_) -> String.compare a b) lst in - let new_pp ppf (k, {field_type=v;_}) = fprintf ppf "@[%a -> %a@]" label k value v in + let new_pp ppf (k, ({field_type=v;_}:field_content)) = fprintf ppf "@[%a -> %a@]" label k value v in fprintf ppf "%a" (list_sep new_pp sep) lst let record_sep value sep ppf (m : 'a label_map) = diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index 515bf3b0c..8b6d47262 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -40,7 +40,7 @@ let t_variable ?loc n : type_expression = make_t ?loc @@ T_variable (Var.of_ let t_record_ez ?loc lst = let lst = List.mapi (fun i (k, v) -> (Label k, {field_type=v;field_decl_pos=i})) lst in let m = LMap.of_list lst in - make_t ?loc @@ T_record m + make_t ?loc @@ T_record (m:field_content label_map) let t_record ?loc m : type_expression = let lst = Map.String.to_kv_list m in t_record_ez ?loc lst @@ -49,9 +49,9 @@ let t_tuple ?loc lst : type_expression = make_t ?loc @@ T_tuple lst let t_pair ?loc (a , b) : type_expression = t_tuple ?loc [a; b] let ez_t_sum ?loc (lst:(string * type_expression) list) : type_expression = - let aux prev (k, v) = CMap.add (Constructor k) v prev in - let map = List.fold_left aux CMap.empty lst in - make_t ?loc @@ T_sum map + let aux (prev,i) (k, v) = (CMap.add (Constructor k) {ctor_type=v;ctor_decl_pos=i} prev, i+1) in + let (map,_) = List.fold_left aux (CMap.empty,0) lst in + make_t ?loc @@ T_sum (map: ctor_content constructor_map) let t_sum ?loc m : type_expression = let lst = Map.String.to_kv_list m in ez_t_sum ?loc lst diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 56c039f06..7a5146c65 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -5,7 +5,7 @@ module Location = Simple_utils.Location include Stage_common.Types type type_content = - | T_sum of type_expression constructor_map + | T_sum of ctor_content constructor_map | T_record of field_content label_map | T_tuple of type_expression list | T_arrow of arrow @@ -15,7 +15,9 @@ type type_content = and arrow = {type1: type_expression; type2: type_expression} -and field_content = {field_type :type_expression ; field_decl_pos : int} +and field_content = {field_type : type_expression ; field_decl_pos : int} + +and ctor_content = {ctor_type : type_expression ; ctor_decl_pos : int} and michelson_prct_annotation = string diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index 4fe98986b..0eb61e0a8 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -19,7 +19,7 @@ type type_content = and arrow = {type1: type_expression; type2: type_expression} -and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option} +and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option ; ctor_decl_pos : int} and field_content = {field_type : type_expression ; michelson_annotation : string option ; field_decl_pos : int} diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index 355058560..617f5c912 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -40,6 +40,7 @@ and annot_option = string option and ctor_content = { ctor_type : type_expression; michelson_annotation : annot_option; + ctor_decl_pos : int; } and field_content = { diff --git a/src/stages/common/types.ml b/src/stages/common/types.ml index 505e60d2d..ecede3cb5 100644 --- a/src/stages/common/types.ml +++ b/src/stages/common/types.ml @@ -47,7 +47,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct and arrow = {type1: type_expression; type2: type_expression} - and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option} + and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option ; ctor_decl_pos : int} and field_content = {field_type : type_expression ; field_annotation : string option ; field_decl_pos : int} diff --git a/src/test/contracts/michelson_converter_or.mligo b/src/test/contracts/michelson_converter_or.mligo new file mode 100644 index 000000000..3394ab7fa --- /dev/null +++ b/src/test/contracts/michelson_converter_or.mligo @@ -0,0 +1,21 @@ +type st4 = + | Foo4 of int + | Bar4 of nat + | Baz4 of string + | Boz4 of bool + +type st3 = + | Foo3 of int + | Bar3 of nat + | Baz3 of string + +(** convert_to **) + +let vst3 = Bar3 3n +let vst4 = Baz4 "eq" + +let str3 = Layout.convert_to_right_comb (vst3:st3) +let str4 = Layout.convert_to_right_comb (vst4:st4) + +let stl3 = Layout.convert_to_left_comb (vst3:st3) +let stl4 = Layout.convert_to_left_comb (vst4:st4) \ No newline at end of file diff --git a/src/test/contracts/michelson_converter.mligo b/src/test/contracts/michelson_converter_pair.mligo similarity index 95% rename from src/test/contracts/michelson_converter.mligo rename to src/test/contracts/michelson_converter_pair.mligo index a7d573d55..29bd17d1c 100644 --- a/src/test/contracts/michelson_converter.mligo +++ b/src/test/contracts/michelson_converter_pair.mligo @@ -1,12 +1,12 @@ type t3 = { foo : int ; bar : nat ; baz : string} type t4 = { one: int ; two : nat ; three : string ; four : bool} - (*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 r3 = Layout.convert_to_right_comb (v3:t3) let r4 = Layout.convert_to_right_comb (v4:t4) let l3 = Layout.convert_to_left_comb (v3:t3) @@ -17,13 +17,13 @@ let l4 = Layout.convert_to_left_comb (v4:t4) 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_pair_right_comb -type param_l = t4 michelson_pair_left_comb +type param_r = t4 michelson_pair_right_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 +type param_l = t4 michelson_pair_left_comb 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 + ([] : operation list), r4.three ^ p.0.1 diff --git a/src/test/typer_tests.ml b/src/test/typer_tests.ml index f6c1f8296..7c22aa842 100644 --- a/src/test/typer_tests.ml +++ b/src/test/typer_tests.ml @@ -56,8 +56,8 @@ module TestExpressions = struct let constructor () : unit result = let variant_foo_bar : (Typed.constructor' * Typed.ctor_content) list = [ - (Typed.Constructor "foo", {ctor_type = Typed.t_int () ; michelson_annotation = None}); - (Typed.Constructor "bar", {ctor_type = Typed.t_string () ; michelson_annotation = None}) ] + (Typed.Constructor "foo", {ctor_type = Typed.t_int () ; michelson_annotation = None ; ctor_decl_pos = 0}); + (Typed.Constructor "bar", {ctor_type = Typed.t_string () ; michelson_annotation = None ; ctor_decl_pos = 1}) ] in test_expression ~env:(E.env_sum_type variant_foo_bar) I.(e_constructor "foo" (e_int (Z.of_int 32)))