From 33337420376deee5e862a30033307ebb78922f8b Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Wed, 22 Apr 2020 19:44:21 +0200 Subject: [PATCH] Converters for michelson types --- src/bin/expect_tests/michelson_converter.ml | 45 ++++++++++++++ src/passes/10-transpiler/transpiler.ml | 2 + src/passes/10-transpiler/untranspiler.ml | 2 + .../2-concrete_to_imperative/cameligo.ml | 4 +- .../2-concrete_to_imperative/pascaligo.ml | 6 +- src/passes/3-self_ast_imperative/helpers.ml | 9 ++- .../imperative_to_sugar.ml | 12 ++-- src/passes/6-sugar_to_core/sugar_to_core.ml | 10 +-- .../8-typer-new/todo_use_fold_generator.ml | 2 + src/passes/8-typer-new/typer.ml | 6 +- src/passes/8-typer-new/untyper.ml | 6 +- src/passes/8-typer-old/typer.ml | 13 +++- .../9-self_ast_typed/michelson_layout.ml | 62 +++++++++++++++++++ src/passes/9-self_ast_typed/self_ast_typed.ml | 3 +- src/passes/operators/helpers.ml | 59 ++++++++++++++++++ src/passes/operators/helpers.mli | 9 +++ src/passes/operators/operators.ml | 25 ++++++++ src/stages/1-ast_imperative/PP.ml | 8 ++- src/stages/1-ast_imperative/combinators.ml | 2 +- src/stages/1-ast_imperative/types.ml | 4 +- src/stages/2-ast_sugar/combinators.ml | 4 +- src/stages/2-ast_sugar/types.ml | 2 +- src/stages/4-ast_typed/PP.ml | 2 + src/stages/4-ast_typed/combinators.ml | 18 ++++-- src/stages/4-ast_typed/combinators.mli | 1 + src/stages/4-ast_typed/helpers.ml | 2 +- src/stages/4-ast_typed/types.ml | 3 + src/stages/5-mini_c/PP.ml | 2 + src/stages/common/PP.ml | 2 + src/stages/common/types.ml | 4 +- src/test/contracts/michelson_converter.mligo | 11 ++++ .../michelson_converter_no_annotation.mligo | 4 ++ .../michelson_converter_short_record.mligo | 4 ++ vendors/ligo-utils/simple-utils/trace.ml | 4 ++ vendors/ligo-utils/simple-utils/x_map.ml | 5 ++ 35 files changed, 321 insertions(+), 36 deletions(-) create mode 100644 src/bin/expect_tests/michelson_converter.ml create mode 100644 src/passes/9-self_ast_typed/michelson_layout.ml create mode 100644 src/test/contracts/michelson_converter.mligo create mode 100644 src/test/contracts/negative/michelson_converter_no_annotation.mligo create mode 100644 src/test/contracts/negative/michelson_converter_short_record.mligo diff --git a/src/bin/expect_tests/michelson_converter.ml b/src/bin/expect_tests/michelson_converter.ml new file mode 100644 index 000000000..8d604534f --- /dev/null +++ b/src/bin/expect_tests/michelson_converter.ml @@ -0,0 +1,45 @@ +open Cli_expect + +let contract basename = + "../../test/contracts/" ^ basename +let bad_contract basename = + "../../test/contracts/negative/" ^ 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 + + If you're not sure how to fix this error, you can + do one of the following: + + * Visit our documentation: https://ligolang.org/docs/intro/introduction + * Ask a question on our Discord: https://discord.gg/9rhYaEt + * Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new + * Check the changelog by running 'ligo changelog' |}] ; + + run_ligo_bad [ "interpret" ; "--init-file="^(bad_contract "michelson_converter_short_record.mligo") ; "l1"] ; + [%expect {| + ligo: in file "michelson_converter_short_record.mligo", line 4, characters 9-44. converted record must have at least two elements + + If you're not sure how to fix this error, you can + do one of the following: + + * Visit our documentation: https://ligolang.org/docs/intro/introduction + * Ask a question on our Discord: https://discord.gg/9rhYaEt + * Open a gitlab issue: https://gitlab.com/ligolang/ligo/issues/new + * Check the changelog by running 'ligo changelog' |}] + +let%expect_test _ = + run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "r3"] ; + [%expect {| + ( 2 , ( +3 , "q" ) ) |}] ; + run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "r4"] ; + [%expect {| + ( 2 , ( +3 , ( "q" , true ) ) ) |}] ; + run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "l3"] ; + [%expect {| + ( ( 2 , +3 ) , "q" ) |}] ; + run_ligo_good [ "interpret" ; "--init-file="^(contract "michelson_converter.mligo") ; "l4"] ; + [%expect {| + ( ( ( 2 , +3 ) , "q" ) , true ) |}] ; diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index a7ca1f555..4e0055b4e 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -228,6 +228,8 @@ let transpile_constant' : AST.constant' -> constant' = function | C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT | C_SET_DELEGATE -> C_SET_DELEGATE | 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 let rec transpile_type (t:AST.type_expression) : type_value result = match t.type_content with diff --git a/src/passes/10-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml index edec0b53f..28feaa1aa 100644 --- a/src/passes/10-transpiler/untranspiler.ml +++ b/src/passes/10-transpiler/untranspiler.ml @@ -236,6 +236,8 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record" | Full t -> ok t in let%bind lst = + (* let () = Format.printf "\n%a\n" Ast_typed.PP.type_expression t in + let () = Format.printf "\n%a\n" Mini_c.PP.value v in *) trace_strong (corner_case ~loc:__LOC__ "record extract") @@ extract_record v node in let%bind lst = bind_list diff --git a/src/passes/2-concrete_to_imperative/cameligo.ml b/src/passes/2-concrete_to_imperative/cameligo.ml index 33d8cca21..9648edadb 100644 --- a/src/passes/2-concrete_to_imperative/cameligo.ml +++ b/src/passes/2-concrete_to_imperative/cameligo.ml @@ -294,14 +294,16 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te - | TRecord r -> let (r, loc) = r_split r in let aux = fun (x, y) -> let%bind y = compile_type_expression y in ok (x, y) in + let order = fun i (x,y) -> ((x,i),y) in let apply (x:Raw.field_decl Raw.reg) = (x.value.field_name.value, x.value.field_type) in let%bind lst = bind_list @@ List.map aux + @@ List.mapi order @@ List.map apply @@ npseq_to_list r.ne_elements in - let m = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in + let m = List.fold_left (fun m ((x,i), y) -> LMap.add (Label x) {field_type=y;decl_position=i} m) LMap.empty lst in ok @@ make_t ~loc @@ T_record m | TSum s -> let (s,loc) = r_split s in diff --git a/src/passes/2-concrete_to_imperative/pascaligo.ml b/src/passes/2-concrete_to_imperative/pascaligo.ml index 4ebef1559..006f2c60b 100644 --- a/src/passes/2-concrete_to_imperative/pascaligo.ml +++ b/src/passes/2-concrete_to_imperative/pascaligo.ml @@ -224,13 +224,17 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result = let%bind y = compile_type_expression y in ok (x, y) in + let order = fun i (x,y) -> + ((x,i),y) + in let apply = fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type) in let%bind lst = bind_list @@ List.map aux + @@ List.mapi order @@ List.map apply @@ npseq_to_list r.ne_elements in - let m = List.fold_left (fun m (x, y) -> LMap.add (Label x) y m) LMap.empty lst in + let m = List.fold_left (fun m ((x,i), y) -> LMap.add (Label x) {field_type=y;decl_position=i} m) LMap.empty lst in ok @@ make_t ~loc @@ T_record m | TSum s -> let (s,loc) = r_split s in diff --git a/src/passes/3-self_ast_imperative/helpers.ml b/src/passes/3-self_ast_imperative/helpers.ml index 159aa7bfb..557243f98 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_lmap_t f map = bind_lmap ( + LMap.map + (fun ({field_type;_} as field) -> + let%bind field_type = f field_type in + ok {field with field_type }) + map) + type 'a folder = 'a -> expression -> 'a result let rec fold_expression : 'a folder -> 'a -> expression -> 'a result = fun f init e -> let self = fold_expression f in @@ -253,7 +260,7 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re let%bind temap' = bind_map_cmap self temap in return @@ (T_sum temap') | T_record temap -> - let%bind temap' = bind_map_lmap self temap in + let%bind temap' = bind_map_lmap_t self temap in return @@ (T_record temap') | T_tuple telst -> let%bind telst' = bind_map_list self telst 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 bdaf7f495..9605c9799 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -145,9 +145,9 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result | I.T_record record -> let record = I.LMap.to_kv_list record in let%bind record = - bind_map_list (fun (k,v) -> + bind_map_list (fun (k, ({field_type = v; decl_position ; _}:I.field_content)) -> let%bind v = compile_type_expression v in - let content : O.field_content = {field_type = v ; michelson_annotation = None} in + let content : O.field_content = {field_type = v; michelson_annotation = None ; decl_position} in ok @@ (k,content) ) record in @@ -171,8 +171,8 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result | I.T_operator (TC_michelson_pair (l,l_ann,r,r_ann)) -> let%bind (l,r) = bind_map_pair compile_type_expression (l,r) in let sum : (O.label * O.field_content) list = [ - (O.Label "0" , {field_type = l ; michelson_annotation = Some l_ann}); - (O.Label "1", {field_type = r ; michelson_annotation = Some r_ann}); ] + (O.Label "0" , {field_type = l ; michelson_annotation = Some l_ann ; decl_position = 0}); + (O.Label "1", {field_type = r ; michelson_annotation = Some r_ann ; decl_position = 0}); ] in return @@ O.T_record (O.LMap.of_list sum) | I.T_operator type_operator -> @@ -600,9 +600,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul let record = I.LMap.to_kv_list record in let%bind record = bind_map_list (fun (k,v) -> - let {field_type;_} : O.field_content = v in + let {field_type;decl_position} : O.field_content = v in let%bind v = uncompile_type_expression field_type in - ok @@ (k,v) + ok @@ (k,({field_type=v;decl_position}:I.field_content)) ) record in return @@ I.T_record (O.LMap.of_list record) 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 c10098f45..b80c7262f 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -21,9 +21,9 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result = let record = I.LMap.to_kv_list record in let%bind record = bind_map_list (fun (k,v) -> - let {field_type ; michelson_annotation} : I.field_content = v in + let {field_type ; michelson_annotation ; decl_position} : I.field_content = v in let%bind field_type = idle_type_expression field_type in - let v' : O.field_content = {field_type ; field_annotation=michelson_annotation} in + let v' : O.field_content = {field_type ; field_annotation=michelson_annotation ; decl_position} in ok @@ (k,v') ) record in @@ -31,7 +31,7 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result = | I.T_tuple tuple -> let aux (i,acc) el = let%bind el = idle_type_expression el in - ok @@ (i+1,(O.Label (string_of_int i), ({field_type=el;field_annotation=None}:O.field_content))::acc) in + ok @@ (i+1,(O.Label (string_of_int i), ({field_type=el;field_annotation=None;decl_position=0}:O.field_content))::acc) in let%bind (_, lst ) = bind_fold_list aux (0,[]) tuple in let record = O.LMap.of_list lst in return @@ O.T_record record @@ -249,9 +249,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul let record = I.LMap.to_kv_list record in let%bind record = bind_map_list (fun (k,v) -> - let {field_type;field_annotation} : O.field_content = v in + let {field_type;field_annotation;decl_position} : O.field_content = v in let%bind field_type = uncompile_type_expression field_type in - let v' : I.field_content = {field_type;michelson_annotation=field_annotation} in + let v' : I.field_content = {field_type ; michelson_annotation=field_annotation ; decl_position} in ok @@ (k,v') ) record in 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 ce3e2fe98..097426109 100644 --- a/src/passes/8-typer-new/todo_use_fold_generator.ml +++ b/src/passes/8-typer-new/todo_use_fold_generator.ml @@ -133,3 +133,5 @@ let convert_constant' : I.constant' -> O.constant' = function | C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT | C_SET_DELEGATE -> C_SET_DELEGATE | 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 diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index e6c7955a7..b2df08bf4 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -142,9 +142,9 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu | T_record m -> let aux k v prev = let%bind prev' = prev in - let {field_type ; field_annotation} : I.field_content = v in + let {field_type ; field_annotation ; decl_position} : I.field_content = v in let%bind field_type = evaluate_type e field_type in - ok @@ O.LMap.add (convert_label k) ({field_type ; michelson_annotation=field_annotation}:O.field_content) prev' + ok @@ O.LMap.add (convert_label k) ({field_type ; michelson_annotation=field_annotation ; decl_position}:O.field_content) prev' in let%bind m = I.LMap.fold aux m (ok O.LMap.empty) in return (T_record m) @@ -300,7 +300,7 @@ and type_expression : environment -> O.typer_state -> ?tv_opt:O.type_expression ok (O.LMap.add (convert_label k) expr' acc , state') in let%bind (m' , state') = Stage_common.Helpers.bind_fold_lmap aux (ok (O.LMap.empty , state)) m in - let wrapped = Wrap.record (O.LMap.map (fun e -> ({field_type = get_type_expression e ; michelson_annotation = None}: O.field_content)) m') in + let wrapped = Wrap.record (O.LMap.map (fun e -> ({field_type = get_type_expression e ; michelson_annotation = None ; decl_position = 0}: O.field_content)) m') in return_wrapped (E_record m') state' wrapped | E_record_update {record; path; update} -> let%bind (record, state) = type_expression e state record in diff --git a/src/passes/8-typer-new/untyper.ml b/src/passes/8-typer-new/untyper.ml index 11b3ef3b9..3fd9f4320 100644 --- a/src/passes/8-typer-new/untyper.ml +++ b/src/passes/8-typer-new/untyper.ml @@ -135,6 +135,8 @@ let unconvert_constant' : O.constant' -> I.constant' = function | C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT | C_SET_DELEGATE -> C_SET_DELEGATE | 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 let untype_type_value (t:O.type_expression) : (I.type_expression) result = match t.type_meta with @@ -156,10 +158,10 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul let%bind x' = O.CMap.fold aux x (ok I.CMap.empty) in ok @@ I.T_sum x' | O.T_record x -> - let aux k ({field_type ; michelson_annotation} : O.field_content) acc = + let aux k ({field_type ; michelson_annotation ; decl_position} : O.field_content) acc = let%bind acc = acc in let%bind field_type = untype_type_expression field_type in - let v' = ({field_type ; field_annotation=michelson_annotation} : I.field_content) in + let v' = ({field_type ; field_annotation=michelson_annotation ; decl_position} : I.field_content) in ok @@ I.LMap.add (unconvert_label k) v' acc in let%bind x' = O.LMap.fold aux x (ok I.LMap.empty) in ok @@ I.T_record x' diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index 67385c1d5..88e17a595 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -350,6 +350,8 @@ let convert_constant' : I.constant' -> O.constant' = function | C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT | C_SET_DELEGATE -> C_SET_DELEGATE | 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 let unconvert_constant' : O.constant' -> I.constant' = function | C_INT -> C_INT @@ -465,6 +467,8 @@ let unconvert_constant' : O.constant' -> I.constant' = function | C_IMPLICIT_ACCOUNT -> C_IMPLICIT_ACCOUNT | C_SET_DELEGATE -> C_SET_DELEGATE | 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 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) = @@ -604,10 +608,10 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu let%bind m = I.CMap.fold aux m (ok O.CMap.empty) in return (T_sum m) | T_record m -> - let aux k ({field_type;field_annotation}: I.field_content) prev = + let aux k ({field_type;field_annotation;decl_position}: I.field_content) prev = let%bind prev' = prev in let%bind field_type = evaluate_type e field_type in - let v' = ({field_type;michelson_annotation=field_annotation} : O.field_content) in + let v' = ({field_type;michelson_annotation=field_annotation;decl_position} : O.field_content) in ok @@ O.LMap.add (convert_label k) v' prev' in let%bind m = I.LMap.fold aux m (ok O.LMap.empty) in @@ -759,7 +763,10 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression ok (O.LMap.add (convert_label k) expr' prev) in let%bind m' = Stage_common.Helpers.bind_fold_lmap aux (ok O.LMap.empty) m in - let lmap = O.LMap.map (fun e -> ({field_type = get_type_expression e; michelson_annotation = None}:O.field_content)) m' in + (* let () = match tv_opt with + Some _ -> Format.printf "YES" + | None -> Format.printf "NO" in *) + let lmap = O.LMap.map (fun e -> ({field_type = get_type_expression e; michelson_annotation = None; decl_position=0}:O.field_content)) m' in return (E_record m') (t_record lmap ()) | E_record_update {record; path; update} -> let path = convert_label path in diff --git a/src/passes/9-self_ast_typed/michelson_layout.ml b/src/passes/9-self_ast_typed/michelson_layout.ml new file mode 100644 index 000000000..abfd39bd7 --- /dev/null +++ b/src/passes/9-self_ast_typed/michelson_layout.ml @@ -0,0 +1,62 @@ +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 rec to_right_comb_e l new_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' + +let rec to_left_comb_e_ first l new_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' + +let to_left_comb_e = to_left_comb_e_ true + +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 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 diff --git a/src/passes/9-self_ast_typed/self_ast_typed.ml b/src/passes/9-self_ast_typed/self_ast_typed.ml index e8dfefdce..fc9d27a5c 100644 --- a/src/passes/9-self_ast_typed/self_ast_typed.ml +++ b/src/passes/9-self_ast_typed/self_ast_typed.ml @@ -1,7 +1,8 @@ open Trace let all_passes = [ - Tail_recursion.peephole_expression + Tail_recursion.peephole_expression ; + Michelson_layout.peephole_expression ; ] let contract_passes = [ diff --git a/src/passes/operators/helpers.ml b/src/passes/operators/helpers.ml index f248b1dc4..a062aa36a 100644 --- a/src/passes/operators/helpers.ml +++ b/src/passes/operators/helpers.ml @@ -133,6 +133,65 @@ module Typer = struct type_expression_eq (t_bool () , b) in ok @@ t_bool () + module Converter = struct + open Ast_typed + + let record_checks kvl = + let%bind () = Assert.assert_true_err + (simple_error "converted record must have at least two elements") + (List.length kvl >=2) in + let all_undefined = List.for_all (fun (_,{decl_position;_}) -> decl_position = 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") + (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 field_type = { + type_content = t ; + type_meta = None ; + location = Location.generated ; } in + {field_type ; michelson_annotation = Some "" ; decl_position = 0} + + let rec to_right_comb_t l new_map = + match l with + | [] -> new_map + | [ (Label ann_l, field_content_l) ; (Label ann_r, field_content_r) ] -> + LMap.add_bindings [ + (Label "0" , annotate_field field_content_l ann_l) ; + (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' + + 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' + | (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 + + let convert_type_to_right_comb l = + let l' = List.sort (fun (_,{decl_position=a;_}) (_,{decl_position=b;_}) -> Int.compare a b) l in + T_record (to_right_comb_t l' LMap.empty) + + 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) + end + end module Compiler = struct diff --git a/src/passes/operators/helpers.mli b/src/passes/operators/helpers.mli index 005ad8d6c..faba8fe85 100644 --- a/src/passes/operators/helpers.mli +++ b/src/passes/operators/helpers.mli @@ -53,6 +53,15 @@ module Typer : sig val comparator : string -> typer val boolean_operator_2 : string -> typer + module Converter : 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 + + end end module Compiler : sig diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index e2ff180ba..46f748890 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -156,6 +156,12 @@ module Concrete_to_imperative = struct | "String.sub" -> Some C_SLICE | "String.concat" -> Some C_CONCAT + (* michelson pair/or type converter module *) + + | "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 *) + | _ -> None @@ -271,6 +277,9 @@ module Concrete_to_imperative = struct | "assert" -> Some C_ASSERTION | "size" -> Some C_SIZE (* Deprecated *) + + | "Layout.convert_to_right_comb" -> Some C_CONVERT_TO_RIGHT_COMB + | "Layout.convert_to_left_comb" -> Some C_CONVERT_TO_LEFT_COMB | _ as c -> pseudo_modules c @@ -1155,6 +1164,20 @@ 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_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 constant_typers c : typer result = match c with | C_INT -> ok @@ int ; | C_UNIT -> ok @@ unit ; @@ -1247,6 +1270,8 @@ module Typer = struct | C_IMPLICIT_ACCOUNT -> ok @@ implicit_account; | C_SET_DELEGATE -> ok @@ set_delegate ; | 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 diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index c17860f9f..75c1805c2 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -13,6 +13,12 @@ let cmap_sep value sep ppf m = 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 + fprintf ppf "%a" (list_sep new_pp sep) lst + let record_sep 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 @@ -30,7 +36,7 @@ let rec type_expression' : fun f ppf te -> match te.type_content with | T_sum m -> fprintf ppf "sum[%a]" (cmap_sep_d f) m - | T_record m -> fprintf ppf "{%a}" (record_sep f (const ";")) m + | T_record m -> fprintf ppf "{%a}" (record_sep_t f (const ";")) m | T_tuple t -> fprintf ppf "(%a)" (list_sep_d f) t | T_arrow a -> fprintf ppf "%a -> %a" f a.type1 f a.type2 | T_variable tv -> type_variable ppf tv diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index be9583890..2dc62fabc 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -38,7 +38,7 @@ let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_opti let t_list ?loc t : type_expression = make_t ?loc @@ T_operator (TC_list t) let t_variable ?loc n : type_expression = make_t ?loc @@ T_variable (Var.of_name n) let t_record_ez ?loc lst = - let lst = List.map (fun (k, v) -> (Label k, v)) lst in + let lst = List.mapi (fun i (k, v) -> (Label k, {field_type=v;decl_position=i})) lst in let m = LMap.of_list lst in make_t ?loc @@ T_record m let t_record ?loc m : type_expression = diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index adb4cbbf5..532f41670 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -6,7 +6,7 @@ include Stage_common.Types type type_content = | T_sum of type_expression constructor_map - | T_record of type_expression label_map + | T_record of field_content label_map | T_tuple of type_expression list | T_arrow of arrow | T_variable of type_variable @@ -15,6 +15,8 @@ type type_content = and arrow = {type1: type_expression; type2: type_expression} +and field_content = {field_type :type_expression ; decl_position : int} + and michelson_prct_annotation = string and type_operator = diff --git a/src/stages/2-ast_sugar/combinators.ml b/src/stages/2-ast_sugar/combinators.ml index dc8268eb8..fc5ea986b 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -52,8 +52,8 @@ let t_record ?loc m : type_expression = t_record_ez ?loc lst let t_pair ?loc (a , b) : type_expression = t_record_ez ?loc [ - ("0",{field_type=a;michelson_annotation=None}) ; - ("1",{field_type=b;michelson_annotation=None})] + ("0",{field_type=a ; michelson_annotation=None ; decl_position=0}) ; + ("1",{field_type=b ; michelson_annotation=None ; decl_position=0})] let t_tuple ?loc lst : type_expression = t_record_ez ?loc (tuple_to_record lst) let ez_t_sum ?loc (lst:((string * ctor_content) list)) : type_expression = diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index c2007d945..e08fc701f 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -21,7 +21,7 @@ and arrow = {type1: type_expression; type2: type_expression} and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option} -and field_content = {field_type : type_expression ; michelson_annotation : string option} +and field_content = {field_type : type_expression ; michelson_annotation : string option ; decl_position : int} and type_operator = | TC_contract of type_expression diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index 08fd13a21..9030d05f2 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -175,6 +175,8 @@ let constant ppf : constant' -> unit = function | C_IMPLICIT_ACCOUNT -> fprintf ppf "IMPLICIT_ACCOUNT" | C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE" | 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" let literal ppf (l : literal) = match l with diff --git a/src/stages/4-ast_typed/combinators.ml b/src/stages/4-ast_typed/combinators.ml index 13532e414..0bb5e710b 100644 --- a/src/stages/4-ast_typed/combinators.ml +++ b/src/stages/4-ast_typed/combinators.ml @@ -51,15 +51,19 @@ let t_list t ?loc ?s () : type_expression = make_t ?loc (T_operator (TC_list let t_set t ?loc ?s () : type_expression = make_t ?loc (T_operator (TC_set t)) s let t_contract t ?loc ?s () : type_expression = make_t ?loc (T_operator (TC_contract t)) s + let t_record m ?loc ?s () : type_expression = make_t ?loc (T_record m) s let make_t_ez_record ?loc (lst:(string * type_expression) list) : type_expression = - let lst = List.map (fun (x,y) -> (Label x, {field_type=y;michelson_annotation=None}) ) lst in + let lst = List.mapi (fun i (x,y) -> (Label x, {field_type=y;michelson_annotation=None;decl_position=i}) ) lst in let map = LMap.of_list lst in make_t ?loc (T_record map) None let ez_t_record lst ?loc ?s () : type_expression = let m = LMap.of_list lst in t_record m ?loc ?s () -let t_pair a b ?loc ?s () : type_expression = ez_t_record [(Label "0",{field_type=a;michelson_annotation=None}) ; (Label "1",{field_type=b;michelson_annotation=None})] ?loc ?s () +let t_pair a b ?loc ?s () : type_expression = + ez_t_record [ + (Label "0",{field_type=a;michelson_annotation=None ; decl_position = 0}) ; + (Label "1",{field_type=b;michelson_annotation=None ; decl_position = 0}) ] ?loc ?s () let t_map ?loc k v ?s () = make_t ?loc (T_operator (TC_map { k ; v })) s let t_big_map ?loc k v ?s () = make_t ?loc (T_operator (TC_big_map { k ; v })) s @@ -183,7 +187,7 @@ let get_t_function_full (t:type_expression) : (type_expression * type_expression | _ -> ([],t) in let (input,output) = aux 0 t in - let input = List.map (fun (l,t) -> (l,{field_type = t ; michelson_annotation = None})) input in + let input = List.map (fun (l,t) -> (l,{field_type = t ; michelson_annotation = None ; decl_position = 0})) input in ok @@ (t_record (LMap.of_list input) (),output) let get_t_sum (t:type_expression) : ctor_content constructor_map result = match t.type_content with @@ -242,6 +246,10 @@ let assert_t_list t = let%bind _ = get_t_list t in ok () +let assert_t_record t = + let%bind _ = get_t_record t in + ok () + let is_t_list = Function.compose to_bool get_t_list let is_t_set = Function.compose to_bool get_t_set let is_t_nat = Function.compose to_bool get_t_nat @@ -324,11 +332,11 @@ let e_a_record r = make_e (e_record r) (t_record (LMap.map (fun t -> let field_type = get_type_expression t in - {field_type ; michelson_annotation=None} ) + {field_type ; michelson_annotation=None ; decl_position = 0} ) r ) () ) let e_a_application a b = make_e (e_application a b) (get_type_expression b) let e_a_variable v ty = make_e (e_variable v) ty -let ez_e_a_record r = make_e (ez_e_record r) (ez_t_record (List.map (fun (x, y) -> x, {field_type = y.type_expression ; michelson_annotation = None}) r) ()) +let ez_e_a_record r = make_e (ez_e_record r) (ez_t_record (List.mapi (fun i (x, y) -> x, {field_type = y.type_expression ; michelson_annotation = None ; decl_position = i}) r) ()) let e_a_let_in binder expr body attributes = make_e (e_let_in binder expr body attributes) (get_type_expression body) diff --git a/src/stages/4-ast_typed/combinators.mli b/src/stages/4-ast_typed/combinators.mli index a80fad951..485dc6185 100644 --- a/src/stages/4-ast_typed/combinators.mli +++ b/src/stages/4-ast_typed/combinators.mli @@ -103,6 +103,7 @@ val assert_t_nat : type_expression -> unit result val assert_t_bool : type_expression -> unit result val assert_t_unit : type_expression -> unit result val assert_t_contract : type_expression -> unit result +val assert_t_record : type_expression -> unit result (* val e_record : ae_map -> expression val ez_e_record : ( string * expression ) list -> expression diff --git a/src/stages/4-ast_typed/helpers.ml b/src/stages/4-ast_typed/helpers.ml index 7bcc4a934..f9ad68a76 100644 --- a/src/stages/4-ast_typed/helpers.ml +++ b/src/stages/4-ast_typed/helpers.ml @@ -174,7 +174,7 @@ let is_michelson_pair (t: _ label_map) = LMap.cardinal t = 2 && let l = LMap.to_list t in List.fold_left - (fun prev {field_type=_;michelson_annotation} -> match michelson_annotation with + (fun prev {michelson_annotation;_} -> match michelson_annotation with | Some _ -> true | None -> prev) false diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index 4b0882119..3f2871f66 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -45,6 +45,7 @@ and ctor_content = { and field_content = { field_type : type_expression; michelson_annotation : annot_option; + decl_position : int; } and type_map_args = { @@ -254,6 +255,8 @@ and constant' = | C_IMPLICIT_ACCOUNT | C_SET_DELEGATE | C_CREATE_CONTRACT + | C_CONVERT_TO_LEFT_COMB + | C_CONVERT_TO_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 96b9499a4..dd9aaae79 100644 --- a/src/stages/5-mini_c/PP.ml +++ b/src/stages/5-mini_c/PP.ml @@ -248,6 +248,8 @@ and constant ppf : constant' -> unit = function | C_IMPLICIT_ACCOUNT -> fprintf ppf "IMPLICIT_ACCOUNT" | C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE" | 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" 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 914a8bad6..c71023bb8 100644 --- a/src/stages/common/PP.ml +++ b/src/stages/common/PP.ml @@ -125,6 +125,8 @@ let constant ppf : constant' -> unit = function | C_IMPLICIT_ACCOUNT -> fprintf ppf "IMPLICIT_ACCOUNT" | C_SET_DELEGATE -> fprintf ppf "SET_DELEGATE" | 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" let literal ppf (l : literal) = match l with diff --git a/src/stages/common/types.ml b/src/stages/common/types.ml index 31582d372..bebc87e84 100644 --- a/src/stages/common/types.ml +++ b/src/stages/common/types.ml @@ -49,7 +49,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct and ctor_content = {ctor_type : type_expression ; michelson_annotation : string option} - and field_content = {field_type : type_expression ; field_annotation : string option} + and field_content = {field_type : type_expression ; field_annotation : string option ; decl_position : int} and type_operator = | TC_contract of type_expression @@ -294,3 +294,5 @@ and constant' = | C_IMPLICIT_ACCOUNT | C_SET_DELEGATE | C_CREATE_CONTRACT + | C_CONVERT_TO_LEFT_COMB + | C_CONVERT_TO_RIGHT_COMB diff --git a/src/test/contracts/michelson_converter.mligo b/src/test/contracts/michelson_converter.mligo new file mode 100644 index 000000000..ea9aaa93d --- /dev/null +++ b/src/test/contracts/michelson_converter.mligo @@ -0,0 +1,11 @@ +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 } + +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) +let l4 = Layout.convert_to_left_comb (v4:t4) \ No newline at end of file diff --git a/src/test/contracts/negative/michelson_converter_no_annotation.mligo b/src/test/contracts/negative/michelson_converter_no_annotation.mligo new file mode 100644 index 000000000..7f777045a --- /dev/null +++ b/src/test/contracts/negative/michelson_converter_no_annotation.mligo @@ -0,0 +1,4 @@ +type t4 = { one: int ; two : nat ; three : string ; four : bool} +let v4 = { one = 2 ; two = 3n ; three = "q" ; four = true } + +let l4 = Layout.convert_to_left_comb v4 \ No newline at end of file diff --git a/src/test/contracts/negative/michelson_converter_short_record.mligo b/src/test/contracts/negative/michelson_converter_short_record.mligo new file mode 100644 index 000000000..d42441adc --- /dev/null +++ b/src/test/contracts/negative/michelson_converter_short_record.mligo @@ -0,0 +1,4 @@ +type t1 = { foo : int } +let v1 = { foo = 2 } + +let l1 = Layout.convert_to_left_comb (v1:t1) \ No newline at end of file diff --git a/vendors/ligo-utils/simple-utils/trace.ml b/vendors/ligo-utils/simple-utils/trace.ml index 0c3bcbcdd..fb143e27c 100644 --- a/vendors/ligo-utils/simple-utils/trace.ml +++ b/vendors/ligo-utils/simple-utils/trace.ml @@ -752,6 +752,10 @@ module Assert = struct true -> ok () | false -> simple_fail msg + let assert_true_err err = function + | true -> ok () + | false -> fail err + let assert_equal ?msg expected actual = assert_true ?msg (expected = actual) diff --git a/vendors/ligo-utils/simple-utils/x_map.ml b/vendors/ligo-utils/simple-utils/x_map.ml index ded0b83e2..31ebe310f 100644 --- a/vendors/ligo-utils/simple-utils/x_map.ml +++ b/vendors/ligo-utils/simple-utils/x_map.ml @@ -6,6 +6,7 @@ module type S = sig val of_list : (key * 'a) list -> 'a t val to_list : 'a t -> 'a list val to_kv_list : 'a t -> (key * 'a) list + val add_bindings : (key * 'a) list -> 'a t -> 'a t end module Make(Ord : Map.OrderedType) : S with type key = Ord.t = struct @@ -22,6 +23,10 @@ module Make(Ord : Map.OrderedType) : S with type key = Ord.t = struct let to_kv_list (t: 'a t) : (key * 'a) list = let aux k v prev = (k, v) :: prev in fold aux t [] + + let add_bindings (kvl:(key * 'a) list) (m:'a t) = + let aux prev (k, v) = add k v prev in + List.fold_left aux m kvl end module String = Make(String)