From 5bed9dadef248d05f4f32343d27be2ef0376428f Mon Sep 17 00:00:00 2001 From: Lesenechal Remi Date: Sat, 18 Apr 2020 00:02:33 +0200 Subject: [PATCH] WIP: michelson_pair --- src/main/compile/of_typed.ml | 4 +- src/passes/10-transpiler/transpiler.ml | 21 +++++-- src/passes/10-transpiler/untranspiler.ml | 2 +- .../2-concrete_to_imperative/pascaligo.ml | 15 +++++ .../imperative_to_sugar.ml | 15 ++++- src/passes/5-self_ast_sugar/helpers.ml | 9 ++- src/passes/6-sugar_to_core/sugar_to_core.ml | 14 +++-- src/passes/7-self_ast_core/helpers.ml | 9 ++- src/passes/8-typer-new/typer.ml | 9 +-- src/passes/8-typer-new/untyper.ml | 5 +- src/passes/8-typer-new/wrap.ml | 8 ++- src/passes/8-typer-old/typer.ml | 12 ++-- .../9-self_ast_typed/no_nested_big_map.ml | 2 +- src/stages/1-ast_imperative/PP.ml | 7 +++ src/stages/1-ast_imperative/combinators.ml | 1 + src/stages/1-ast_imperative/combinators.mli | 8 +-- src/stages/1-ast_imperative/types.ml | 3 +- src/stages/2-ast_sugar/PP.ml | 11 +++- src/stages/2-ast_sugar/combinators.ml | 4 +- src/stages/2-ast_sugar/combinators.mli | 6 +- src/stages/2-ast_sugar/types.ml | 4 +- src/stages/3-ast_core/combinators.mli | 8 +-- src/stages/4-ast_typed/PP.ml | 19 +++++- src/stages/4-ast_typed/combinators.ml | 23 ++++--- src/stages/4-ast_typed/combinators.mli | 6 +- src/stages/4-ast_typed/helpers.ml | 18 +++++- src/stages/4-ast_typed/misc.ml | 2 +- src/stages/4-ast_typed/types.ml | 7 ++- src/stages/common/PP.ml | 61 ++++++++++++------- src/stages/common/types.ml | 4 +- src/test/contracts/michelson_pair_tree.ligo | 8 +++ 31 files changed, 240 insertions(+), 85 deletions(-) create mode 100644 src/test/contracts/michelson_pair_tree.ligo diff --git a/src/main/compile/of_typed.ml b/src/main/compile/of_typed.ml index 43b2216fe..8bcbfd882 100644 --- a/src/main/compile/of_typed.ml +++ b/src/main/compile/of_typed.ml @@ -15,8 +15,8 @@ let assert_equal_contract_type : check_type -> string -> Ast_typed.program -> As | T_arrow {type1=args} -> ( match args.type_content with | T_record m when LMap.cardinal m = 2 -> ( - let param_exp = LMap.find (Label "0") m in - let storage_exp = LMap.find (Label "1") m in + let {field_type=param_exp;_} = LMap.find (Label "0") m in + let {field_type=storage_exp;_} = LMap.find (Label "1") m in match c with | Check_parameter -> assert_type_expression_eq (param_exp, param.type_expression) | Check_storage -> assert_type_expression_eq (storage_exp, param.type_expression) diff --git a/src/passes/10-transpiler/transpiler.ml b/src/passes/10-transpiler/transpiler.ml index 3949f34ff..f1a764953 100644 --- a/src/passes/10-transpiler/transpiler.ml +++ b/src/passes/10-transpiler/transpiler.ml @@ -298,6 +298,19 @@ let rec transpile_type (t:AST.type_expression) : type_value result = ok (Some (String.uncapitalize_ascii ann), a)) aux node in ok @@ snd m' + | T_record m when Ast_typed.Helpers.is_michelson_pair m -> + let node = Append_tree.of_list @@ Ast_typed.Helpers.tuple_of_record m in + let aux a b : type_value annotated result = + let%bind a = a in + let%bind b = b in + ok (None, T_pair (a, b)) + in + let%bind m' = Append_tree.fold_ne + (fun (_, ({field_type ; michelson_annotation} : AST.field_content)) -> + let%bind a = transpile_type field_type in + ok (michelson_annotation, a) ) + aux node in + ok @@ snd m' | T_record m -> let is_tuple_lmap = Ast_typed.Helpers.is_tuple_lmap m in let node = Append_tree.of_list @@ ( @@ -313,8 +326,8 @@ let rec transpile_type (t:AST.type_expression) : type_value result = ok (None, T_pair (a, b)) in let%bind m' = Append_tree.fold_ne - (fun (Ast_typed.Types.Label ann, a) -> - let%bind a = transpile_type a in + (fun (Ast_typed.Types.Label ann, ({field_type;_}: AST.field_content)) -> + let%bind a = transpile_type field_type in ok ((if is_tuple_lmap then None else @@ -448,7 +461,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = let%bind ty_lmap = trace_strong (corner_case ~loc:__LOC__ "not a record") @@ get_t_record (get_type_expression record) in - let%bind ty'_lmap = Ast_typed.Helpers.bind_map_lmap transpile_type ty_lmap in + let%bind ty'_lmap = Ast_typed.Helpers.bind_map_lmap_t transpile_type ty_lmap in let%bind path = trace_strong (corner_case ~loc:__LOC__ "record access") @@ record_access_to_lr ty' ty'_lmap path in @@ -465,7 +478,7 @@ and transpile_annotated_expression (ae:AST.expression) : expression result = let%bind ty_lmap = trace_strong (corner_case ~loc:__LOC__ "not a record") @@ get_t_record (get_type_expression record) in - let%bind ty'_lmap = Ast_typed.Helpers.bind_map_lmap transpile_type ty_lmap in + let%bind ty'_lmap = Ast_typed.Helpers.bind_map_lmap_t transpile_type ty_lmap in let%bind path = trace_strong (corner_case ~loc:__LOC__ "record access") @@ record_access_to_lr ty' ty'_lmap path in diff --git a/src/passes/10-transpiler/untranspiler.ml b/src/passes/10-transpiler/untranspiler.ml index a727eedff..bf59c6a81 100644 --- a/src/passes/10-transpiler/untranspiler.ml +++ b/src/passes/10-transpiler/untranspiler.ml @@ -231,7 +231,7 @@ let rec untranspile (v : value) (t : AST.type_expression) : AST.expression resul let%bind sub = untranspile v tv in return (E_constructor {constructor=Constructor name;element=sub}) | T_record m -> - let lst = Ast_typed.Helpers.kv_list_of_record_or_tuple m in + let lst = List.map (fun (k,{field_type;_}) -> (k,field_type)) @@ Ast_typed.Helpers.kv_list_of_record_or_tuple m in let%bind node = match Append_tree.of_list lst with | Empty -> fail @@ corner_case ~loc:__LOC__ "empty record" | Full t -> ok t in diff --git a/src/passes/2-concrete_to_imperative/pascaligo.ml b/src/passes/2-concrete_to_imperative/pascaligo.ml index e0bccd831..ca3139655 100644 --- a/src/passes/2-concrete_to_imperative/pascaligo.ml +++ b/src/passes/2-concrete_to_imperative/pascaligo.ml @@ -182,6 +182,21 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result = ok @@ t_michelson_or ~loc a' b' c' d' ) | _ -> simple_fail "michelson_or does not have the right number of argument") + | "michelson_pair" -> + let lst = npseq_to_list tuple.value.inside in + (match lst with + | [a ; b ; c ; d ] -> ( + let%bind b' = + trace_option (simple_error "second argument of michelson_pair must be a string singleton") @@ + get_t_string_singleton_opt b in + let%bind d' = + trace_option (simple_error "fourth argument of michelson_pair must be a string singleton") @@ + get_t_string_singleton_opt d in + let%bind a' = compile_type_expression a in + let%bind c' = compile_type_expression c in + ok @@ t_michelson_pair ~loc a' b' c' d' + ) + | _ -> simple_fail "michelson_or does not have the right number of argument") | _ -> let lst = npseq_to_list tuple.value.inside in let%bind lst = 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 5f7240b41..318fe942d 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -129,7 +129,8 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result let%bind record = bind_map_list (fun (k,v) -> let%bind v = compile_type_expression v in - ok @@ (k,v) + let content : O.field_content = {field_type = v ; michelson_annotation = None} in + ok @@ (k,content) ) record in return @@ O.T_record (O.LMap.of_list record) @@ -149,6 +150,13 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result (O.Constructor "M_right", {ctor_type = r ; michelson_annotation = Some r_ann}); ] in return @@ O.T_sum (O.CMap.of_list sum) + | 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 "M_left" , {field_type = l ; michelson_annotation = Some l_ann}); + (O.Label "M_right", {field_type = r ; michelson_annotation = Some r_ann}); ] + in + return @@ O.T_record (O.LMap.of_list sum) | I.T_operator type_operator -> let%bind type_operator = compile_type_operator type_operator in return @@ T_operator type_operator @@ -177,7 +185,7 @@ and compile_type_operator : I.type_operator -> O.type_operator result = | TC_arrow (i,o) -> let%bind (i,o) = bind_map_pair compile_type_expression (i,o) in ok @@ O.TC_arrow (i,o) - | TC_michelson_or _ -> fail @@ Errors.corner_case __LOC__ + | TC_michelson_or _ | TC_michelson_pair _ -> fail @@ Errors.corner_case __LOC__ let rec compile_expression : I.expression -> O.expression result = fun e -> @@ -587,7 +595,8 @@ 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%bind v = uncompile_type_expression v in + let {field_type;_} : O.field_content = v in + let%bind v = uncompile_type_expression field_type in ok @@ (k,v) ) record in diff --git a/src/passes/5-self_ast_sugar/helpers.ml b/src/passes/5-self_ast_sugar/helpers.ml index 4559e0429..0d3b353b7 100644 --- a/src/passes/5-self_ast_sugar/helpers.ml +++ b/src/passes/5-self_ast_sugar/helpers.ml @@ -9,6 +9,13 @@ let bind_map_cmap f map = bind_cmap ( ok {ctor with ctor_type = ctor'}) map) +let bind_map_lmap_t f map = bind_lmap ( + LMap.map + (fun ({field_type;_} as field) -> + let%bind field' = f field_type in + ok {field with field_type = field'}) + 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 @@ -234,7 +241,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/6-sugar_to_core/sugar_to_core.ml b/src/passes/6-sugar_to_core/sugar_to_core.ml index 97e8ea2e2..ce1af8ae2 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -21,15 +21,17 @@ 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%bind v = idle_type_expression v in - ok @@ (k,v) + let {field_type ; michelson_annotation} : 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 + ok @@ (k,v') ) record in return @@ O.T_record (O.LMap.of_list record) | 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), el)::acc) in + ok @@ (i+1,(O.Label (string_of_int i), ({field_type=el;field_annotation=None}: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 @@ -254,8 +256,10 @@ 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%bind v = uncompile_type_expression v in - ok @@ (k,v) + let {field_type;field_annotation} : 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 + ok @@ (k,v') ) record in return @@ I.T_record (O.LMap.of_list record) diff --git a/src/passes/7-self_ast_core/helpers.ml b/src/passes/7-self_ast_core/helpers.ml index b133faef4..e76e4f064 100644 --- a/src/passes/7-self_ast_core/helpers.ml +++ b/src/passes/7-self_ast_core/helpers.ml @@ -12,6 +12,13 @@ let bind_map_cmap f map = bind_cmap ( ok {ctor with ctor_type = ctor'}) map) +let bind_map_lmap_t f map = bind_lmap ( + LMap.map + (fun ({field_type;_} as field) -> + let%bind field' = f field_type in + ok {field with field_type = field'}) + 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 @@ -161,7 +168,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_arrow {type1 ; type2} -> let%bind type1' = self type1 in diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index 1d602f458..71ec621c2 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -147,8 +147,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%bind v' = evaluate_type e v in - ok @@ O.LMap.add (convert_label k) v' prev' + let {field_type ; field_annotation} : 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' in let%bind m = I.LMap.fold aux m (ok O.LMap.empty) in return (T_record m) @@ -311,7 +312,7 @@ and type_expression : environment -> Solver.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 get_type_expression 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 return_wrapped (E_record m') state' wrapped | E_record_update {record; path; update} -> let%bind (record, state) = type_expression e state record in @@ -323,7 +324,7 @@ and type_expression : environment -> Solver.state -> ?tv_opt:O.type_expression - | T_record record -> ( let field_op = O.LMap.find_opt path record in match field_op with - | Some tv -> ok (record,tv) + | Some {field_type=tv;_} -> ok (record,tv) | None -> failwith @@ Format.asprintf "field %a is not part of record" O.PP.label path ) | _ -> failwith "Update an expression which is not a record" diff --git a/src/passes/8-typer-new/untyper.ml b/src/passes/8-typer-new/untyper.ml index 0d3c56162..f082bd072 100644 --- a/src/passes/8-typer-new/untyper.ml +++ b/src/passes/8-typer-new/untyper.ml @@ -157,9 +157,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 v acc = + let aux k ({field_type ; michelson_annotation} : O.field_content) acc = let%bind acc = acc in - let%bind v' = untype_type_expression v in + let%bind field_type = untype_type_expression field_type in + let v' = ({field_type ; field_annotation=michelson_annotation} : 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-new/wrap.ml b/src/passes/8-typer-new/wrap.ml index 5355e7bc8..f51a38140 100644 --- a/src/passes/8-typer-new/wrap.ml +++ b/src/passes/8-typer-new/wrap.ml @@ -38,7 +38,8 @@ let rec type_expression_to_type_value : T.type_expression -> O.type_value = fun P_constant (C_variant, List.map type_expression_to_type_value tlist) | T_record kvmap -> let () = failwith "fixme: don't use to_list, it drops the record keys, rows have a differnt kind than argument lists for now!" in - P_constant (C_record, T.LMap.to_list @@ T.LMap.map type_expression_to_type_value kvmap) + let tlist = List.map (fun ({field_type;_}:T.field_content) -> field_type) (T.LMap.to_list kvmap) in + P_constant (C_record, List.map type_expression_to_type_value tlist) | T_arrow {type1;type2} -> P_constant (C_arrow, List.map type_expression_to_type_value [ type1 ; type2 ]) @@ -85,7 +86,8 @@ let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_v P_constant (C_variant, List.map type_expression_to_type_value_copypasted tlist) | T_record kvmap -> let () = failwith "fixme: don't use to_list, it drops the record keys, rows have a differnt kind than argument lists for now!" in - P_constant (C_record, I.LMap.to_list @@ I.LMap.map type_expression_to_type_value_copypasted kvmap) + let tlist = List.map (fun ({field_type;_}:I.field_content) -> field_type) (I.LMap.to_list kvmap) in + P_constant (C_record, List.map type_expression_to_type_value_copypasted tlist) | T_arrow {type1;type2} -> P_constant (C_arrow, List.map type_expression_to_type_value_copypasted [ type1 ; type2 ]) | T_variable type_name -> P_variable (type_name) (* eird stuff*) @@ -184,7 +186,7 @@ let constructor C_equation (t_arg , c_arg) ] , whole_expr -let record : T.type_expression T.label_map -> (constraints * T.type_variable) = fun fields -> +let record : T.field_content T.label_map -> (constraints * T.type_variable) = fun fields -> let record_type = type_expression_to_type_value (T.t_record fields ()) in let whole_expr = Core.fresh_type_variable () in [C_equation (P_variable whole_expr , record_type)] , whole_expr diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index d1ab5fbb2..7d2a70d8e 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -611,9 +611,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 v prev = + let aux k ({field_type;field_annotation}: I.field_content) prev = let%bind prev' = prev in - let%bind v' = evaluate_type e v in + let%bind field_type = evaluate_type e field_type in + let v' = ({field_type;michelson_annotation=field_annotation} : 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 @@ -724,7 +725,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression let%bind r_tv = get_t_record prev.type_expression in let%bind tv = generic_try (bad_record_access property ae prev.type_expression ae.location) - @@ (fun () -> O.LMap.find (convert_label property) r_tv) in + @@ (fun () -> let ({field_type;_} : O.field_content) = O.LMap.find (convert_label property) r_tv in field_type) in let location = ae.location in ok @@ make_e ~location (E_record_accessor {record=prev; path=convert_label property}) tv e in @@ -771,7 +772,8 @@ 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 - return (E_record m') (t_record (O.LMap.map get_type_expression m') ()) + let lmap = O.LMap.map (fun e -> ({field_type = get_type_expression e; michelson_annotation = None}:O.field_content)) m' in + return (E_record m') (t_record lmap ()) | E_record_update {record; path; update} -> let path = convert_label path in let%bind record = type_expression' e record in @@ -782,7 +784,7 @@ and type_expression' : environment -> ?tv_opt:O.type_expression -> I.expression | T_record record -> ( let field_op = O.LMap.find_opt path record in match field_op with - | Some tv -> ok (tv) + | Some {field_type;_} -> ok field_type | None -> failwith @@ Format.asprintf "field %a is not part of record %a" Ast_typed.PP.label path O.PP.type_expression wrapped ) | _ -> failwith "Update an expression which is not a record" diff --git a/src/passes/9-self_ast_typed/no_nested_big_map.ml b/src/passes/9-self_ast_typed/no_nested_big_map.ml index 8f8f9d51e..710f1b3e4 100644 --- a/src/passes/9-self_ast_typed/no_nested_big_map.ml +++ b/src/passes/9-self_ast_typed/no_nested_big_map.ml @@ -45,7 +45,7 @@ let rec check_no_nested_bigmap is_in_bigmap e = ok () | T_record elm -> let es = LMap.to_list elm in - let%bind _ = bind_map_list (fun l -> check_no_nested_bigmap is_in_bigmap l) es in + let%bind _ = bind_map_list (fun {field_type;_} -> check_no_nested_bigmap is_in_bigmap field_type) es in ok () | T_arrow { type1; type2 } -> let%bind _ = check_no_nested_bigmap false type1 in diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index da65ae284..0b9827d4a 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 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, v) = fprintf ppf "@[%a -> %a@]" label k value v in + fprintf ppf "%a" (list_sep new_pp sep) lst + let expression_variable ppf (ev : expression_variable) : unit = fprintf ppf "%a" Var.pp ev @@ -48,6 +54,7 @@ and type_operator : | TC_map (k, v) -> Format.asprintf "Map (%a,%a)" f k f v | TC_big_map (k, v) -> Format.asprintf "Big Map (%a,%a)" f k f v | TC_michelson_or (l,_, r,_) -> Format.asprintf "Michelson_or (%a,%a)" f l f r + | TC_michelson_pair (l,_, r,_) -> Format.asprintf "Michelson_pair (%a,%a)" f l f r | TC_arrow (k, v) -> Format.asprintf "arrow (%a,%a)" f k f v | TC_contract te -> Format.asprintf "Contract (%a)" f te in diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index e8db1428f..a7bb20945 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -62,6 +62,7 @@ let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator ( let t_set ?loc key : type_expression = make_t ?loc @@ T_operator (TC_set key) let t_contract ?loc contract : type_expression = make_t ?loc @@ T_operator (TC_contract contract) let t_michelson_or ?loc l l_ann r r_ann : type_expression = make_t ?loc @@ T_operator (TC_michelson_or (l, l_ann, r, r_ann)) +let t_michelson_pair ?loc l l_ann r r_ann : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair (l, l_ann, r, r_ann)) (* TODO find a better way than using list*) let t_operator ?loc op lst: type_expression result = diff --git a/src/stages/1-ast_imperative/combinators.mli b/src/stages/1-ast_imperative/combinators.mli index 39f0fb3f5..50105895a 100644 --- a/src/stages/1-ast_imperative/combinators.mli +++ b/src/stages/1-ast_imperative/combinators.mli @@ -42,10 +42,10 @@ val ez_t_sum : ?loc:Location.t -> ( string * type_expression ) list -> type_expr val t_function : ?loc:Location.t -> type_expression -> type_expression -> type_expression val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression -val t_michelson_or : ?loc:Location.t -> -type_expression -> -michelson_prct_annotation -> -type_expression -> michelson_prct_annotation -> type_expression +val t_michelson_or : ?loc:Location.t -> type_expression -> michelson_prct_annotation -> + type_expression -> michelson_prct_annotation -> type_expression +val t_michelson_pair : ?loc:Location.t -> type_expression -> michelson_prct_annotation -> + type_expression -> michelson_prct_annotation -> type_expression val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression result val t_set : ?loc:Location.t -> type_expression -> type_expression diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 8cdc8c6eb..49909998e 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -24,8 +24,9 @@ and type_operator = | TC_set of type_expression | TC_map of type_expression * type_expression | TC_big_map of type_expression * type_expression - | TC_michelson_or of type_expression * michelson_prct_annotation * type_expression * michelson_prct_annotation | TC_arrow of type_expression * type_expression + | TC_michelson_or of type_expression * michelson_prct_annotation * type_expression * michelson_prct_annotation + | TC_michelson_pair of type_expression * michelson_prct_annotation * type_expression * michelson_prct_annotation and type_expression = {type_content: type_content; location: Location.t} diff --git a/src/stages/2-ast_sugar/PP.ml b/src/stages/2-ast_sugar/PP.ml index 4375d1db3..22f726ff6 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -14,6 +14,13 @@ 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;_}) = fprintf ppf "@[%a -> %a@]" label k value field_type in + fprintf ppf "%a" (list_sep new_pp sep) lst + + let expression_variable ppf (ev : expression_variable) : unit = fprintf ppf "%a" Var.pp ev @@ -25,7 +32,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 @@ -65,7 +72,7 @@ and expression_content ppf (ec : expression_content) = fprintf ppf "%a(%a)" constant c.cons_name (list_sep_d expression) c.arguments | E_record m -> - fprintf ppf "{%a}" (record_sep expression (const ";")) m + fprintf ppf "{%a}" (record_sep_expr expression (const ";")) m | E_record_accessor ra -> fprintf ppf "%a.%a" expression ra.record label ra.path | E_record_update {record; path; update} -> diff --git a/src/stages/2-ast_sugar/combinators.ml b/src/stages/2-ast_sugar/combinators.ml index 60c2758da..99f4072b5 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -51,7 +51,9 @@ let t_record ?loc m : type_expression = let lst = Map.String.to_kv_list m in t_record_ez ?loc lst -let t_pair ?loc (a , b) : type_expression = t_record_ez ?loc [("0",a) ; ("1",b)] +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})] 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/combinators.mli b/src/stages/2-ast_sugar/combinators.mli index e83a307ef..c91279fa9 100644 --- a/src/stages/2-ast_sugar/combinators.mli +++ b/src/stages/2-ast_sugar/combinators.mli @@ -32,10 +32,10 @@ val t_variable : ?loc:Location.t -> string -> type_expression val t_record : te_map -> type_expression *) val t_pair : ?loc:Location.t -> ( type_expression * type_expression ) -> type_expression -val t_tuple : ?loc:Location.t -> type_expression list -> type_expression +val t_tuple : ?loc:Location.t -> field_content list -> type_expression -val t_record : ?loc:Location.t -> type_expression Map.String.t -> type_expression -val t_record_ez : ?loc:Location.t -> (string * type_expression) list -> type_expression +val t_record : ?loc:Location.t -> field_content Map.String.t -> type_expression +val t_record_ez : ?loc:Location.t -> (string * field_content) list -> type_expression val t_sum : ?loc:Location.t -> ctor_content Map.String.t -> type_expression val ez_t_sum : ?loc:Location.t -> ( 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 4e673d1b5..18295b7a5 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -10,7 +10,7 @@ end type type_content = | T_sum of ctor_content 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 @@ -21,6 +21,8 @@ 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 type_operator = | TC_contract of type_expression | TC_option of type_expression diff --git a/src/stages/3-ast_core/combinators.mli b/src/stages/3-ast_core/combinators.mli index 631c36110..9a857b0f7 100644 --- a/src/stages/3-ast_core/combinators.mli +++ b/src/stages/3-ast_core/combinators.mli @@ -31,11 +31,11 @@ val t_variable : ?loc:Location.t -> string -> type_expression (* val t_record : te_map -> type_expression *) -val t_pair : ?loc:Location.t -> ( type_expression * type_expression ) -> type_expression -val t_tuple : ?loc:Location.t -> type_expression list -> type_expression +val t_pair : ?loc:Location.t -> ( field_content * field_content ) -> type_expression +val t_tuple : ?loc:Location.t -> field_content list -> type_expression -val t_record : ?loc:Location.t -> type_expression Map.String.t -> type_expression -val t_record_ez : ?loc:Location.t -> (string * type_expression) list -> type_expression +val t_record : ?loc:Location.t -> field_content Map.String.t -> type_expression +val t_record_ez : ?loc:Location.t -> (string * field_content) list -> type_expression val t_sum : ?loc:Location.t -> Types.ctor_content Map.String.t -> type_expression val ez_t_sum : ?loc:Location.t -> ( string * Types.ctor_content ) list -> type_expression diff --git a/src/stages/4-ast_typed/PP.ml b/src/stages/4-ast_typed/PP.ml index 4b93422e3..25905b310 100644 --- a/src/stages/4-ast_typed/PP.ml +++ b/src/stages/4-ast_typed/PP.ml @@ -31,6 +31,18 @@ let tuple_sep value sep ppf m = let new_pp ppf (_, v) = fprintf ppf "%a" value v in fprintf ppf "%a" (list_sep new_pp sep) lst +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;_}) = fprintf ppf "@[%a -> %a@]" label k value field_type in + fprintf ppf "%a" (list_sep new_pp sep) lst + +let tuple_sep_t value sep ppf m = + assert (Helpers.is_tuple_lmap m); + let lst = Helpers.tuple_of_record m in + let new_pp ppf (_, {field_type;_}) = fprintf ppf "%a" value field_type in + fprintf ppf "%a" (list_sep new_pp sep) lst + (* Prints records which only contain the consecutive fields 0..(cardinal-1) as tuples *) let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple ppf m = @@ -38,11 +50,16 @@ let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple pp fprintf ppf format_tuple (tuple_sep value (tag sep_tuple)) m else fprintf ppf format_record (record_sep value (tag sep_record)) m +let tuple_or_record_sep_t value format_record sep_record format_tuple sep_tuple ppf m = + if Helpers.is_tuple_lmap m then + fprintf ppf format_tuple (tuple_sep_t value (tag sep_tuple)) m + else + fprintf ppf format_record (record_sep_t value (tag sep_record)) m let list_sep_d x = list_sep x (tag " ,@ ") let cmap_sep_d x = cmap_sep x (tag " ,@ ") let tuple_or_record_sep_expr value = tuple_or_record_sep value "@[record[%a]@]" " ,@ " "@[( %a )@]" " ,@ " -let tuple_or_record_sep_type value = tuple_or_record_sep value "@[record[%a]@]" " ,@ " "@[( %a )@]" " *@ " +let tuple_or_record_sep_type value = tuple_or_record_sep_t value "@[record[%a]@]" " ,@ " "@[( %a )@]" " *@ " let constant ppf : constant' -> unit = function | C_INT -> fprintf ppf "INT" diff --git a/src/stages/4-ast_typed/combinators.ml b/src/stages/4-ast_typed/combinators.ml index 43613c100..54a6e6b22 100644 --- a/src/stages/4-ast_typed/combinators.ml +++ b/src/stages/4-ast_typed/combinators.ml @@ -54,13 +54,13 @@ let t_contract t ?loc ?s () : type_expression = make_t ?loc (T_operator (TC_cont 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, y) ) lst in + let lst = List.map (fun (x,y) -> (Label x, {field_type=y;michelson_annotation=None}) ) 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",a) ; (Label "1",b)] ?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_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 @@ -150,7 +150,9 @@ let tuple_of_record (m: _ LMap.t) = let opt = LMap.find_opt (Label (string_of_int i)) m in Option.bind (fun opt -> Some (opt,i+1)) opt in - Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux + let l = Base.Sequence.to_list @@ Base.Sequence.unfold ~init:0 ~f:aux in + List.map (fun {field_type;_} -> field_type) l + let get_t_tuple (t:type_expression) : type_expression list result = match t.type_content with | T_record lst -> ok @@ tuple_of_record lst @@ -178,13 +180,14 @@ 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 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 | T_sum m -> ok m | _ -> fail @@ Errors.not_a_x_type "sum" t () -let get_t_record (t:type_expression) : type_expression label_map result = match t.type_content with +let get_t_record (t:type_expression) : field_content label_map result = match t.type_content with | T_record m -> ok m | _ -> fail @@ Errors.not_a_x_type "record" t () @@ -306,14 +309,20 @@ let e_a_mutez n = make_e (e_mutez n) (t_mutez ()) let e_a_bool b = make_e (e_bool b) (t_bool ()) let e_a_string s = make_e (e_string s) (t_string ()) let e_a_address s = make_e (e_address s) (t_address ()) -let e_a_pair a b = make_e (e_pair a b) (t_pair a.type_expression b.type_expression ()) +let e_a_pair a b = make_e (e_pair a b) + (t_pair a.type_expression b.type_expression () ) let e_a_some s = make_e (e_some s) (t_option s.type_expression ()) let e_a_lambda l in_ty out_ty = make_e (e_lambda l) (t_function in_ty out_ty ()) let e_a_none t = make_e (e_none ()) (t_option t ()) -let e_a_record r = make_e (e_record r) (t_record (LMap.map get_type_expression r) ()) +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} ) + 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, y.type_expression) r) ()) +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 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 0b9315088..9c7523e9e 100644 --- a/src/stages/4-ast_typed/combinators.mli +++ b/src/stages/4-ast_typed/combinators.mli @@ -25,9 +25,9 @@ val t_option : type_expression -> ?loc:Location.t -> ?s:S.type_expression -> uni val t_pair : type_expression -> type_expression -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression val t_list : type_expression -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression val t_variable : type_variable -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression -val t_record : type_expression label_map -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression +val t_record : te_lmap -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression val make_t_ez_record : ?loc:Location.t -> (string* type_expression) list -> type_expression -val ez_t_record : ( label * type_expression ) list -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression +val ez_t_record : ( label * field_content ) list -> ?loc:Location.t -> ?s:S.type_expression -> unit -> type_expression val t_map : ?loc:Location.t -> type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression val t_big_map : ?loc:Location.t -> type_expression -> type_expression -> ?s:S.type_expression -> unit -> type_expression @@ -65,7 +65,7 @@ val get_t_pair : type_expression -> ( type_expression * type_expression ) result val get_t_function : type_expression -> ( type_expression * type_expression ) result val get_t_function_full : type_expression -> ( type_expression * type_expression ) result val get_t_sum : type_expression -> ctor_content constructor_map result -val get_t_record : type_expression -> type_expression label_map result +val get_t_record : type_expression -> field_content label_map result val get_t_map : type_expression -> ( type_expression * type_expression ) result val get_t_big_map : type_expression -> ( type_expression * type_expression ) result val get_t_map_key : type_expression -> type_expression result diff --git a/src/stages/4-ast_typed/helpers.ml b/src/stages/4-ast_typed/helpers.ml index 67f7cd108..4aa1a374b 100644 --- a/src/stages/4-ast_typed/helpers.ml +++ b/src/stages/4-ast_typed/helpers.ml @@ -120,6 +120,11 @@ let bind_fold_lmap f init (lmap:_ LMap.t) = LMap.fold aux lmap init let bind_map_lmap f map = bind_lmap (LMap.map f map) +let bind_map_lmap_t f map = bind_lmap ( + LMap.map + (fun ({field_type;_}) -> + f field_type) + map) let bind_map_cmap f map = bind_cmap (CMap.map f map) let bind_map_lmapi f map = bind_lmap (LMap.mapi f map) let bind_map_cmapi f map = bind_cmap (CMap.mapi f map) @@ -137,7 +142,7 @@ let is_tuple_lmap m = let get_pair m = let open Trace in match (LMap.find_opt (Label "0") m , LMap.find_opt (Label "1") m) with - | Some e1, Some e2 -> ok (e1,e2) + | Some {field_type=e1;_}, Some {field_type=e2;_} -> ok (e1,e2) | _ -> simple_fail "not a pair" let tuple_of_record (m: _ LMap.t) = @@ -164,4 +169,13 @@ let kv_list_of_record_or_tuple (m: _ LMap.t) = let is_michelson_or (t: _ constructor_map) = CMap.cardinal t = 2 && (CMap.mem (Constructor "M_left") t) && - (CMap.mem (Constructor "M_right") t) \ No newline at end of file + (CMap.mem (Constructor "M_right") t) + +let is_michelson_pair (t: _ label_map) = + let l = LMap.to_list t in + List.fold_left + (fun prev {field_type=_;michelson_annotation} -> match michelson_annotation with + | Some _ -> true + | None -> prev) + false + l diff --git a/src/stages/4-ast_typed/misc.ml b/src/stages/4-ast_typed/misc.ml index 423220a13..8612f2ece 100644 --- a/src/stages/4-ast_typed/misc.ml +++ b/src/stages/4-ast_typed/misc.ml @@ -377,7 +377,7 @@ let rec assert_type_expression_eq (a, b: (type_expression * type_expression)) : let sort_lmap r' = List.sort (fun (Label a,_) (Label b,_) -> String.compare a b) r' in let ra' = sort_lmap @@ LMap.to_kv_list ra in let rb' = sort_lmap @@ LMap.to_kv_list rb in - let aux ((ka, va), (kb, vb)) = + let aux ((ka, {field_type=va;_}), (kb, {field_type=vb;_})) = let%bind _ = trace (different_types "records" a b) @@ let Label ka = ka in diff --git a/src/stages/4-ast_typed/types.ml b/src/stages/4-ast_typed/types.ml index 099469a21..a25734369 100644 --- a/src/stages/4-ast_typed/types.ml +++ b/src/stages/4-ast_typed/types.ml @@ -20,7 +20,7 @@ type type_constant = | TC_void type te_cmap = ctor_content constructor_map -and te_lmap = type_expression label_map +and te_lmap = field_content label_map and type_meta = ast_core_type_expression option and type_content = @@ -43,6 +43,11 @@ and ctor_content = { michelson_annotation : annot_option; } +and field_content = { + field_type : type_expression; + michelson_annotation : annot_option; +} + and type_map_args = { k : type_expression; v : type_expression; diff --git a/src/stages/common/PP.ml b/src/stages/common/PP.ml index 1de0b6e8c..2d784057d 100644 --- a/src/stages/common/PP.ml +++ b/src/stages/common/PP.ml @@ -8,29 +8,8 @@ let constructor ppf (c:constructor') : unit = let label ppf (l:label) : unit = let Label l = l in fprintf ppf "%s" l -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 - let new_pp ppf (k, v) = fprintf ppf "@[%a -> %a@]" label k value v in - fprintf ppf "%a" (list_sep new_pp sep) lst - -let tuple_sep value sep ppf m = - assert (Helpers.is_tuple_lmap m); - let lst = Helpers.tuple_of_record m in - let new_pp ppf (_, v) = fprintf ppf "%a" value v in - fprintf ppf "%a" (list_sep new_pp sep) lst - -(* Prints records which only contain the consecutive fields - 0..(cardinal-1) as tuples *) -let tuple_or_record_sep value format_record sep_record format_tuple sep_tuple ppf m = - if Helpers.is_tuple_lmap m then - fprintf ppf format_tuple (tuple_sep value (tag sep_tuple)) m - else - fprintf ppf format_record (record_sep value (tag sep_record)) m let list_sep_d x = list_sep x (tag " ,@ ") -let tuple_or_record_sep_expr value = tuple_or_record_sep value "@[record[%a]@]" " ,@ " "@[( %a )@]" " ,@ " -let tuple_or_record_sep_type value = tuple_or_record_sep value "@[record[%a]@]" " ,@ " "@[( %a )@]" " *@ " let constant ppf : constant' -> unit = function | C_INT -> fprintf ppf "INT" @@ -200,6 +179,46 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct fprintf ppf "%a" (list_sep new_pp sep) lst let cmap_sep_d x = cmap_sep x (tag " ,@ ") + 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 + let new_pp ppf (k, {field_type;_}) = fprintf ppf "@[%a -> %a@]" label k value field_type in + fprintf ppf "%a" (list_sep new_pp sep) lst + + let tuple_sep value sep ppf m = + assert (Helpers.is_tuple_lmap m); + let lst = Helpers.tuple_of_record m in + let new_pp ppf (_, {field_type;_}) = fprintf ppf "%a" value field_type in + fprintf ppf "%a" (list_sep new_pp sep) lst + + let record_sep_expr 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, v) = fprintf ppf "@[%a -> %a@]" label k value v in + fprintf ppf "%a" (list_sep new_pp sep) lst + + let tuple_sep_expr value sep ppf m = + assert (Helpers.is_tuple_lmap m); + let lst = Helpers.tuple_of_record m in + let new_pp ppf (_,v) = fprintf ppf "%a" value v in + fprintf ppf "%a" (list_sep new_pp sep) lst + + (* Prints records which only contain the consecutive fields + 0..(cardinal-1) as tuples *) + let tuple_or_record_sep_t value format_record sep_record format_tuple sep_tuple ppf m = + if Helpers.is_tuple_lmap m then + fprintf ppf format_tuple (tuple_sep value (tag sep_tuple)) m + else + fprintf ppf format_record (record_sep value (tag sep_record)) m + + let tuple_or_record_sep_expr value format_record sep_record format_tuple sep_tuple ppf m = + if Helpers.is_tuple_lmap m then + fprintf ppf format_tuple (tuple_sep_expr value (tag sep_tuple)) m + else + fprintf ppf format_record (record_sep_expr value (tag sep_record)) m + + let tuple_or_record_sep_expr value = tuple_or_record_sep_expr value "@[record[%a]@]" " ,@ " "@[( %a )@]" " ,@ " + let tuple_or_record_sep_type value = tuple_or_record_sep_t value "@[record[%a]@]" " ,@ " "@[( %a )@]" " *@ " let rec type_expression' : (formatter -> type_expression -> unit) diff --git a/src/stages/common/types.ml b/src/stages/common/types.ml index 5f3b9a84d..c2f7fba56 100644 --- a/src/stages/common/types.ml +++ b/src/stages/common/types.ml @@ -40,7 +40,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct type type_content = | T_sum of ctor_content constructor_map - | T_record of type_expression label_map + | T_record of field_content label_map | T_arrow of arrow | T_variable of type_variable | T_constant of type_constant @@ -50,6 +50,8 @@ 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 type_operator = | TC_contract of type_expression | TC_option of type_expression diff --git a/src/test/contracts/michelson_pair_tree.ligo b/src/test/contracts/michelson_pair_tree.ligo new file mode 100644 index 000000000..10a659251 --- /dev/null +++ b/src/test/contracts/michelson_pair_tree.ligo @@ -0,0 +1,8 @@ +type inner_storage is michelson_pair(int,"one",nat,"two") +type storage is michelson_pair (string,"three",inner_storage,"four") + +type return is list(operation) * storage + +function main (const action : unit; const store : storage) : return is block { + const foo : storage = ("foo",(1,2n)) ; +} with ((nil : list(operation)), (foo: storage))