diff --git a/src/bin/expect_tests/contract_tests.ml b/src/bin/expect_tests/contract_tests.ml index c52e7c366..3c5a794e6 100644 --- a/src/bin/expect_tests/contract_tests.ml +++ b/src/bin/expect_tests/contract_tests.ml @@ -1321,7 +1321,7 @@ let%expect_test _ = let%expect_test _ = run_ligo_bad [ "compile-contract" ; contract "bad_type_operator.ligo" ; "main" ] ; [%expect {| - ligo: bad type operator (TO_Map (unit,unit)): + ligo: bad type operator (type_operator: Map (binding)): If you're not sure how to fix this error, you can do one of the following: diff --git a/src/passes/2-concrete_to_imperative/cameligo.ml b/src/passes/2-concrete_to_imperative/cameligo.ml index a9f80a5b2..9df82adb1 100644 --- a/src/passes/2-concrete_to_imperative/cameligo.ml +++ b/src/passes/2-concrete_to_imperative/cameligo.ml @@ -286,7 +286,7 @@ and compile_type_expression : Raw.type_expr -> type_expression result = fun te - let%bind cst = trace_option (unknown_predefined_type name) @@ type_operators name.value in - t_operator ~loc cst lst' ) + ok @@ t_operator ~loc cst lst' ) ) | TProd p -> ( let%bind tpl = compile_list_type_expression @@ npseq_to_list p.value in diff --git a/src/passes/2-concrete_to_imperative/pascaligo.ml b/src/passes/2-concrete_to_imperative/pascaligo.ml index 1d5d51ef3..b0c2820f3 100644 --- a/src/passes/2-concrete_to_imperative/pascaligo.ml +++ b/src/passes/2-concrete_to_imperative/pascaligo.ml @@ -213,7 +213,7 @@ let rec compile_type_expression (t:Raw.type_expr) : type_expression result = let%bind cst = trace_option (unknown_predefined_type name) @@ type_operators name.value in - t_operator ~loc cst lst) + ok @@ t_operator ~loc cst lst) | TProd p -> let%bind tpl = compile_list_type_expression @@ npseq_to_list p.value in diff --git a/src/passes/3-self_ast_imperative/helpers.ml b/src/passes/3-self_ast_imperative/helpers.ml index e08e1ef53..018219a78 100644 --- a/src/passes/3-self_ast_imperative/helpers.ml +++ b/src/passes/3-self_ast_imperative/helpers.ml @@ -276,6 +276,9 @@ and map_type_expression : ty_exp_mapper -> type_expression -> type_expression re let%bind type1' = self type1 in let%bind type2' = self type2 in return @@ (T_arrow {type1=type1' ; type2=type2'}) + | T_annoted (ty, str) -> + let%bind ty = self ty in + return @@ T_annoted (ty, str) | T_operator _ | T_variable _ | T_constant _ -> ok te' 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 224c2de10..4017db346 100644 --- a/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml +++ b/src/passes/4-imperative_to_sugar/imperative_to_sugar.ml @@ -161,58 +161,28 @@ let rec compile_type_expression : I.type_expression -> O.type_expression result return @@ T_arrow {type1;type2} | I.T_variable type_variable -> return @@ T_variable type_variable | I.T_constant type_constant -> return @@ T_constant type_constant - | I.T_operator (TC_michelson_or (l,l_ann,r,r_ann)) -> + | I.T_operator (TC_michelson_or, [l;r]) -> + let%bind (l, l_ann) = I.get_t_annoted l in + let%bind (r, r_ann) = I.get_t_annoted r in 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 ; 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)) -> + | I.T_operator (TC_michelson_pair, [l;r]) -> + let%bind (l, l_ann) = I.get_t_annoted l in + let%bind (r, r_ann) = I.get_t_annoted r in 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 ; field_decl_pos = 0}); (O.Label "1", {field_type = r ; michelson_annotation = Some r_ann ; field_decl_pos = 0}); ] 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 - -and compile_type_operator : I.type_operator -> O.type_operator result = - fun t_o -> - match t_o with - | TC_contract c -> - let%bind c = compile_type_expression c in - ok @@ O.TC_contract c - | TC_option o -> - let%bind o = compile_type_expression o in - ok @@ O.TC_option o - | TC_list l -> - let%bind l = compile_type_expression l in - ok @@ O.TC_list l - | TC_set s -> - let%bind s = compile_type_expression s in - ok @@ O.TC_set s - | TC_map (k,v) -> - let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in - ok @@ O.TC_map (k,v) - | TC_big_map (k,v) -> - let%bind (k,v) = bind_map_pair compile_type_expression (k,v) in - ok @@ O.TC_big_map (k,v) - | TC_michelson_or _ | TC_michelson_pair _ -> fail @@ Errors.corner_case __LOC__ - | TC_michelson_pair_right_comb c -> - let%bind c = compile_type_expression c in - ok @@ O.TC_michelson_pair_right_comb c - | TC_michelson_pair_left_comb c -> - let%bind c = compile_type_expression c in - ok @@ O.TC_michelson_pair_left_comb c - | TC_michelson_or_right_comb c -> - let%bind c = compile_type_expression c in - ok @@ O.TC_michelson_or_right_comb c - | TC_michelson_or_left_comb c -> - let%bind c = compile_type_expression c in - ok @@ O.TC_michelson_or_left_comb c + | I.T_operator (type_operator, lst) -> + let%bind lst = bind_map_list compile_type_expression lst in + return @@ T_operator (type_operator, lst) + | I.T_annoted (ty, _) -> compile_type_expression ty let rec compile_expression : I.expression -> O.expression result = fun e -> @@ -627,43 +597,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul return @@ T_arrow {type1;type2} | O.T_variable type_variable -> return @@ T_variable type_variable | O.T_constant type_constant -> return @@ T_constant type_constant - | O.T_operator type_operator -> - let%bind type_operator = uncompile_type_operator type_operator in - return @@ T_operator type_operator - -and uncompile_type_operator : O.type_operator -> I.type_operator result = - fun t_o -> - match t_o with - | TC_contract c -> - let%bind c = uncompile_type_expression c in - ok @@ I.TC_contract c - | TC_option o -> - let%bind o = uncompile_type_expression o in - ok @@ I.TC_option o - | TC_list l -> - let%bind l = uncompile_type_expression l in - ok @@ I.TC_list l - | TC_set s -> - let%bind s = uncompile_type_expression s in - ok @@ I.TC_set s - | TC_map (k,v) -> - let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in - ok @@ I.TC_map (k,v) - | TC_big_map (k,v) -> - let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in - ok @@ I.TC_big_map (k,v) - | TC_michelson_pair_right_comb c -> - let%bind c = uncompile_type_expression c in - ok @@ I.TC_michelson_pair_right_comb c - | TC_michelson_pair_left_comb c -> - let%bind c = uncompile_type_expression c in - ok @@ I.TC_michelson_pair_left_comb c - | TC_michelson_or_right_comb c -> - let%bind c = uncompile_type_expression c in - ok @@ I.TC_michelson_or_right_comb c - | TC_michelson_or_left_comb c -> - let%bind c = uncompile_type_expression c in - ok @@ I.TC_michelson_or_left_comb c + | O.T_operator (type_operator, lst) -> + let%bind lst = bind_map_list uncompile_type_expression lst in + return @@ T_operator (type_operator, lst) let rec uncompile_expression' : O.expression -> I.expression result = fun e -> 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 165ff5577..3a106a3ce 100644 --- a/src/passes/6-sugar_to_core/sugar_to_core.ml +++ b/src/passes/6-sugar_to_core/sugar_to_core.ml @@ -41,43 +41,9 @@ let rec idle_type_expression : I.type_expression -> O.type_expression result = return @@ T_arrow {type1;type2} | I.T_variable type_variable -> return @@ T_variable type_variable | I.T_constant type_constant -> return @@ T_constant type_constant - | I.T_operator type_operator -> - let%bind type_operator = idle_type_operator type_operator in - return @@ T_operator type_operator - -and idle_type_operator : I.type_operator -> O.type_operator result = - fun t_o -> - match t_o with - | TC_contract c -> - let%bind c = idle_type_expression c in - ok @@ O.TC_contract c - | TC_option o -> - let%bind o = idle_type_expression o in - ok @@ O.TC_option o - | TC_list l -> - let%bind l = idle_type_expression l in - ok @@ O.TC_list l - | TC_set s -> - let%bind s = idle_type_expression s in - ok @@ O.TC_set s - | TC_map (k,v) -> - let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in - ok @@ O.TC_map (k,v) - | TC_big_map (k,v) -> - let%bind (k,v) = bind_map_pair idle_type_expression (k,v) in - ok @@ O.TC_big_map (k,v) - | TC_michelson_pair_right_comb c -> - let%bind c = idle_type_expression c in - ok @@ O.TC_michelson_pair_right_comb c - | TC_michelson_pair_left_comb c -> - let%bind c = idle_type_expression c in - ok @@ O.TC_michelson_pair_left_comb c - | TC_michelson_or_right_comb c -> - let%bind c = idle_type_expression c in - ok @@ O.TC_michelson_or_right_comb c - | TC_michelson_or_left_comb c -> - let%bind c = idle_type_expression c in - ok @@ O.TC_michelson_or_left_comb c + | I.T_operator (type_operator, lst) -> + let%bind lst = bind_map_list idle_type_expression lst in + return @@ T_operator (type_operator, lst) let rec compile_expression : I.expression -> O.expression result = fun e -> @@ -274,44 +240,9 @@ let rec uncompile_type_expression : O.type_expression -> I.type_expression resul return @@ T_arrow {type1;type2} | O.T_variable type_variable -> return @@ T_variable type_variable | O.T_constant type_constant -> return @@ T_constant type_constant - | O.T_operator type_operator -> - let%bind type_operator = uncompile_type_operator type_operator in - return @@ T_operator type_operator - -and uncompile_type_operator : O.type_operator -> I.type_operator result = - fun t_o -> - match t_o with - | TC_contract c -> - let%bind c = uncompile_type_expression c in - ok @@ I.TC_contract c - | TC_option o -> - let%bind o = uncompile_type_expression o in - ok @@ I.TC_option o - | TC_list l -> - let%bind l = uncompile_type_expression l in - ok @@ I.TC_list l - | TC_set s -> - let%bind s = uncompile_type_expression s in - ok @@ I.TC_set s - | TC_map (k,v) -> - let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in - ok @@ I.TC_map (k,v) - | TC_big_map (k,v) -> - let%bind (k,v) = bind_map_pair uncompile_type_expression (k,v) in - ok @@ I.TC_big_map (k,v) - | TC_map_or_big_map _ -> failwith "TC_map_or_big_map shouldn't be uncompiled" - | TC_michelson_pair_right_comb c -> - let%bind c = uncompile_type_expression c in - ok @@ I.TC_michelson_pair_right_comb c - | TC_michelson_pair_left_comb c -> - let%bind c = uncompile_type_expression c in - ok @@ I.TC_michelson_pair_left_comb c - | TC_michelson_or_right_comb c -> - let%bind c = uncompile_type_expression c in - ok @@ I.TC_michelson_or_right_comb c - | TC_michelson_or_left_comb c -> - let%bind c = uncompile_type_expression c in - ok @@ I.TC_michelson_or_left_comb c + | O.T_operator (type_operator, lst) -> + let%bind lst = bind_map_list uncompile_type_expression lst in + return @@ T_operator (type_operator, lst) let rec uncompile_expression : O.expression -> I.expression result = fun e -> diff --git a/src/passes/8-typer-new/errors.ml b/src/passes/8-typer-new/errors.ml index 7446d2f40..866211659 100644 --- a/src/passes/8-typer-new/errors.ml +++ b/src/passes/8-typer-new/errors.ml @@ -150,3 +150,8 @@ let type_error ?(msg="") ~(expected: O.type_expression) ~(actual: O.type_express ("location" , fun () -> Format.asprintf "%a" Location.pp loc) ] in error ~data title message () + +let bad_type_operator type_op = + let title () = Format.asprintf "bad type operator %a" I.PP.type_expression type_op in + let message () = "" in + error title message diff --git a/src/passes/8-typer-new/typer.ml b/src/passes/8-typer-new/typer.ml index d81a8e690..cd2c3ce12 100644 --- a/src/passes/8-typer-new/typer.ml +++ b/src/passes/8-typer-new/typer.ml @@ -156,36 +156,37 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu ok tv | T_constant cst -> return (T_constant (convert_type_constant cst)) - | T_operator opt -> - let%bind opt = match opt with - | TC_set s -> + | T_operator (op, lst) -> + let%bind opt = match op,lst with + | TC_set, [s] -> let%bind s = evaluate_type e s in ok @@ O.TC_set (s) - | TC_option o -> + | TC_option, [o] -> let%bind o = evaluate_type e o in ok @@ O.TC_option (o) - | TC_list l -> + | TC_list, [l] -> let%bind l = evaluate_type e l in ok @@ O.TC_list (l) - | TC_map (k,v) -> + | TC_map, [k;v] -> let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in ok @@ O.TC_map {k;v} - | TC_big_map (k,v) -> + | TC_big_map, [k;v] -> let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in ok @@ O.TC_big_map {k;v} - | TC_map_or_big_map (k,v) -> + | TC_map_or_big_map, [k;v] -> let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in ok @@ O.TC_map_or_big_map {k;v} - | TC_contract c -> + | TC_contract, [c] -> let%bind c = evaluate_type e c in ok @@ O.TC_contract c - | TC_michelson_pair_right_comb _c | TC_michelson_pair_left_comb _c - | TC_michelson_or_right_comb _c | TC_michelson_or_left_comb _c -> + | TC_michelson_pair_right_comb, _c | TC_michelson_pair_left_comb, _c + | TC_michelson_or_right_comb, _c | TC_michelson_or_left_comb, _c -> (* not really sure what to do in the new typer, should be converted to a pair using functions defined in Helpers.Typer.Converter *) simple_fail "to be implemented" + | _ -> fail @@ bad_type_operator t in return (T_operator (opt)) diff --git a/src/passes/8-typer-new/untyper.ml b/src/passes/8-typer-new/untyper.ml index 22bab7ba7..91d554664 100644 --- a/src/passes/8-typer-new/untyper.ml +++ b/src/passes/8-typer-new/untyper.ml @@ -178,28 +178,28 @@ let rec untype_type_expression (t:O.type_expression) : (I.type_expression) resul let%bind type_name = match type_name with | O.TC_option t -> let%bind t' = untype_type_expression t in - ok @@ I.TC_option t' + ok @@ (I.TC_option, [t']) | O.TC_list t -> let%bind t' = untype_type_expression t in - ok @@ I.TC_list t' + ok @@ (I.TC_list, [t']) | O.TC_set t -> let%bind t' = untype_type_expression t in - ok @@ I.TC_set t' + ok @@ (I.TC_set, [t']) | O.TC_map {k;v} -> let%bind k = untype_type_expression k in let%bind v = untype_type_expression v in - ok @@ I.TC_map (k,v) + ok @@ (I.TC_map, [k;v]) | O.TC_big_map {k;v} -> let%bind k = untype_type_expression k in let%bind v = untype_type_expression v in - ok @@ I.TC_big_map (k,v) + ok @@ (I.TC_big_map, [k;v]) | O.TC_map_or_big_map {k;v} -> let%bind k = untype_type_expression k in let%bind v = untype_type_expression v in - ok @@ I.TC_map_or_big_map (k,v) + ok @@ (I.TC_map_or_big_map, [k;v]) | O.TC_contract c-> let%bind c = untype_type_expression c in - ok @@ I.TC_contract c + ok @@ (I.TC_contract, [c]) in ok @@ I.T_operator (type_name) in diff --git a/src/passes/8-typer-new/wrap.ml b/src/passes/8-typer-new/wrap.ml index 5c0302887..b43ba3d5a 100644 --- a/src/passes/8-typer-new/wrap.ml +++ b/src/passes/8-typer-new/wrap.ml @@ -97,19 +97,21 @@ let rec type_expression_to_type_value_copypasted : I.type_expression -> O.type_v | _ -> failwith "unknown type constructor") in p_constant csttag [] - | T_operator (type_name) -> - let (csttag, args) = T.(match type_name with - | TC_option o -> (C_option , [o]) - | TC_list l -> (C_list , [l]) - | TC_set s -> (C_set , [s]) - | TC_map ( k , v ) -> (C_map , [k;v]) - | TC_big_map ( k , v ) -> (C_big_map, [k;v]) - | TC_map_or_big_map ( k , v) -> (C_map, [k;v]) - | TC_contract c -> (C_contract, [c]) - | TC_michelson_pair_right_comb c -> (C_record, [c]) - | TC_michelson_pair_left_comb c -> (C_record, [c]) - | TC_michelson_or_right_comb c -> (C_record, [c]) - | TC_michelson_or_left_comb c -> (C_record, [c]) + | T_operator (type_name, args) -> + let csttag = T.(match type_name with + | TC_option -> C_option + | TC_list -> C_list + | TC_set -> C_set + | TC_map -> C_map + | TC_big_map -> C_big_map + | TC_map_or_big_map -> C_map + | TC_contract -> C_contract + | TC_michelson_pair + | TC_michelson_or + | TC_michelson_pair_right_comb -> C_record + | TC_michelson_pair_left_comb -> C_record + | TC_michelson_or_right_comb -> C_record + | TC_michelson_or_left_comb -> C_record ) in p_constant csttag (List.map type_expression_to_type_value_copypasted args) diff --git a/src/passes/8-typer-old/typer.ml b/src/passes/8-typer-old/typer.ml index d31c41dc5..1dc92eb28 100644 --- a/src/passes/8-typer-old/typer.ml +++ b/src/passes/8-typer-old/typer.ml @@ -230,6 +230,11 @@ module Errors = struct ] in error ~data title message () + let bad_type_operator type_op = + let title () = Format.asprintf "bad type operator %a" I.PP.type_expression type_op in + let message () = "" in + error title message + end open Errors @@ -614,59 +619,60 @@ and evaluate_type (e:environment) (t:I.type_expression) : O.type_expression resu ok tv | T_constant cst -> return (T_constant (convert_type_constant cst)) - | T_operator opt -> ( match opt with - | TC_set s -> + | T_operator (op, lst) -> ( match op,lst with + | TC_set, [s] -> let%bind s = evaluate_type e s in return @@ T_operator (O.TC_set (s)) - | TC_option o -> + | TC_option, [o] -> let%bind o = evaluate_type e o in return @@ T_operator (O.TC_option (o)) - | TC_list l -> + | TC_list, [l] -> let%bind l = evaluate_type e l in return @@ T_operator (O.TC_list (l)) - | TC_map (k,v) -> + | TC_map, [k;v] -> let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in return @@ T_operator (O.TC_map {k;v}) - | TC_big_map (k,v) -> + | TC_big_map, [k;v] -> let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in return @@ T_operator (O.TC_big_map {k;v}) - | TC_map_or_big_map (k,v) -> + | TC_map_or_big_map, [k;v] -> let%bind k = evaluate_type e k in let%bind v = evaluate_type e v in return @@ T_operator (O.TC_map_or_big_map {k;v}) - | TC_contract c -> + | TC_contract, [c] -> let%bind c = evaluate_type e c in return @@ T_operator (O.TC_contract c) - | TC_michelson_pair_right_comb c -> + | TC_michelson_pair_right_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_pair_to_right_comb (Ast_typed.LMap.to_kv_list lmap) in return @@ record - | TC_michelson_pair_left_comb c -> + | 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_pair_to_left_comb (Ast_typed.LMap.to_kv_list lmap) in return @@ record - | TC_michelson_or_right_comb c -> + | TC_michelson_or_right_comb, [c] -> let%bind c' = evaluate_type e c in let%bind cmap = match c'.type_content with | T_sum cmap -> ok cmap | _ -> fail (michelson_comb_no_variant t.location) in let pair = Operators.Typer.Converter.convert_variant_to_right_comb (Ast_typed.CMap.to_kv_list cmap) in return @@ pair - | TC_michelson_or_left_comb c -> + | TC_michelson_or_left_comb, [c] -> let%bind c' = evaluate_type e c in let%bind cmap = match c'.type_content with | T_sum cmap -> ok cmap | _ -> fail (michelson_comb_no_variant t.location) in let pair = Operators.Typer.Converter.convert_variant_to_left_comb (Ast_typed.CMap.to_kv_list cmap) in return @@ pair + | _ -> fail @@ bad_type_operator t ) and type_expression : environment -> O'.typer_state -> ?tv_opt:O.type_expression -> I.expression -> (O.expression * O'.typer_state) result diff --git a/src/passes/operators/operators.ml b/src/passes/operators/operators.ml index dc63d5573..ebafebcba 100644 --- a/src/passes/operators/operators.ml +++ b/src/passes/operators/operators.ml @@ -32,8 +32,6 @@ module Concrete_to_imperative = struct - The left-hand-side is the reserved name in the given front-end. - The right-hand-side is the name that will be used in the AST. *) - let unit_expr = make_t @@ T_constant TC_unit - let type_constants s = match s with "chain_id" -> Some TC_chain_id @@ -53,17 +51,17 @@ module Concrete_to_imperative = struct let type_operators s = match s with - "list" -> Some (TC_list unit_expr) - | "option" -> Some (TC_option unit_expr) - | "set" -> Some (TC_set unit_expr) - | "map" -> Some (TC_map (unit_expr,unit_expr)) - | "big_map" -> Some (TC_big_map (unit_expr,unit_expr)) - | "contract" -> Some (TC_contract unit_expr) - | "michelson_pair_right_comb" -> Some (TC_michelson_pair_right_comb unit_expr) - | "michelson_pair_left_comb" -> Some (TC_michelson_pair_left_comb unit_expr) - | "michelson_or_right_comb" -> Some (TC_michelson_or_right_comb unit_expr) - | "michelson_or_left_comb" -> Some (TC_michelson_or_left_comb unit_expr) - | _ -> None + "list" -> Some (TC_list) + | "option" -> Some (TC_option) + | "set" -> Some (TC_set) + | "map" -> Some (TC_map) + | "big_map" -> Some (TC_big_map) + | "contract" -> Some (TC_contract) + | "michelson_pair_right_comb" -> Some (TC_michelson_pair_right_comb) + | "michelson_pair_left_comb" -> Some (TC_michelson_pair_left_comb) + | "michelson_or_right_comb" -> Some (TC_michelson_or_right_comb) + | "michelson_or_left_comb" -> Some (TC_michelson_or_left_comb) + | _ -> None let pseudo_modules = function | "Tezos.chain_id" -> Some C_CHAIN_ID diff --git a/src/stages/1-ast_imperative/PP.ml b/src/stages/1-ast_imperative/PP.ml index 6a2c835db..986c200ba 100644 --- a/src/stages/1-ast_imperative/PP.ml +++ b/src/stages/1-ast_imperative/PP.ml @@ -42,30 +42,27 @@ let rec type_expression' : | T_variable tv -> type_variable ppf tv | T_constant tc -> type_constant ppf tc | T_operator to_ -> type_operator f ppf to_ + | T_annoted (ty, str) -> fprintf ppf "(%a%%%s)" type_expression ty str and type_expression ppf (te : type_expression) : unit = type_expression' type_expression ppf te -and type_operator : - (formatter -> type_expression -> unit) - -> formatter - -> type_operator - -> unit = +and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator * type_expression list -> unit = fun f ppf to_ -> - let s = - match to_ with - | TC_option te -> Format.asprintf "option(%a)" f te - | TC_list te -> Format.asprintf "list(%a)" f te - | TC_set te -> Format.asprintf "set(%a)" f te - | 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_michelson_pair_right_comb e -> Format.asprintf "michelson_pair_right_comb (%a)" f e - | TC_michelson_pair_left_comb e -> Format.asprintf "michelson_pair_left_comb (%a)" f e - | TC_michelson_or_right_comb e -> Format.asprintf "michelson_or_right_comb (%a)" f e - | TC_michelson_or_left_comb e -> Format.asprintf "michelson_or_left_comb (%a)" f e - | TC_contract te -> Format.asprintf "Contract (%a)" f te + let s = match to_ with + TC_option , lst -> Format.asprintf "option(%a)" (list_sep_d f) lst + | TC_list , lst -> Format.asprintf "list(%a)" (list_sep_d f) lst + | TC_set , lst -> Format.asprintf "set(%a)" (list_sep_d f) lst + | TC_map , lst -> Format.asprintf "Map (%a)" (list_sep_d f) lst + | TC_big_map , lst -> Format.asprintf "Big Map (%a)" (list_sep_d f) lst + | TC_map_or_big_map , lst -> Format.asprintf "Map Or Big Map (%a)" (list_sep_d f) lst + | TC_contract , lst -> Format.asprintf "Contract (%a)" (list_sep_d f) lst + | TC_michelson_pair , lst -> Format.asprintf "michelson_pair (%a)" (list_sep_d f) lst + | TC_michelson_or , lst -> Format.asprintf "michelson_or (%a)" (list_sep_d f) lst + | TC_michelson_pair_right_comb , lst -> Format.asprintf "michelson_pair_right_comb (%a)" (list_sep_d f) lst + | TC_michelson_pair_left_comb , lst -> Format.asprintf "michelson_pair_left_comb (%a)" (list_sep_d f) lst + | TC_michelson_or_right_comb , lst -> Format.asprintf "michelson_or_right_comb (%a)" (list_sep_d f) lst + | TC_michelson_or_left_comb , lst -> Format.asprintf "michelson_or_left_comb (%a)" (list_sep_d f) lst in fprintf ppf "(TO_%s)" s diff --git a/src/stages/1-ast_imperative/combinators.ml b/src/stages/1-ast_imperative/combinators.ml index 4a4e88ed3..aaf589c9a 100644 --- a/src/stages/1-ast_imperative/combinators.ml +++ b/src/stages/1-ast_imperative/combinators.ml @@ -12,10 +12,6 @@ module Errors = struct ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; ] in error ~data title message - let bad_type_operator type_op = - let title () = Format.asprintf "bad type operator %a" (PP.type_operator PP.type_expression) type_op in - let message () = "" in - error title message end open Errors @@ -34,8 +30,8 @@ let t_signature ?loc () : type_expression = make_t ?loc @@ T_constant (TC_sign let t_key ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key) let t_key_hash ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key_hash) let t_timestamp ?loc () : type_expression = make_t ?loc @@ T_constant (TC_timestamp) -let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option o) -let t_list ?loc t : type_expression = make_t ?loc @@ T_operator (TC_list t) +let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option, [o]) +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.mapi (fun i (k, v) -> (Label k, {field_type=v;field_decl_pos=i})) lst in @@ -56,33 +52,25 @@ let t_sum ?loc m : type_expression = let lst = Map.String.to_kv_list m in ez_t_sum ?loc lst -let t_function ?loc type1 type2 : type_expression = make_t ?loc @@ T_arrow {type1; type2} -let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map (key, value)) -let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map (key , value)) -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)) -let t_michelson_pair_right_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair_right_comb c) -let t_michelson_pair_left_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair_left_comb c) -let t_michelson_or_right_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_or_right_comb c) -let t_michelson_or_left_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_or_left_comb c) +let t_operator ?loc op lst: type_expression = make_t ?loc @@ T_operator (op, lst) +let t_annoted ?loc ty str : type_expression = make_t ?loc @@ T_annoted (ty, str) -(* TODO find a better way than using list*) -let t_operator ?loc op lst: type_expression result = - match op,lst with - | TC_set _ , [t] -> ok @@ t_set ?loc t - | TC_list _ , [t] -> ok @@ t_list ?loc t - | TC_option _ , [t] -> ok @@ t_option ?loc t - | TC_map (_,_) , [kt;vt] -> ok @@ t_map ?loc kt vt - | TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map ?loc kt vt - | TC_michelson_or (_,l_ann,_,r_ann) , [l;r] -> ok @@ t_michelson_or ?loc l l_ann r r_ann - | TC_contract _ , [t] -> ok @@ t_contract t - | TC_michelson_pair_right_comb _ , [c] -> ok @@ t_michelson_pair_right_comb c - | TC_michelson_pair_left_comb _ , [c] -> ok @@ t_michelson_pair_left_comb c - | TC_michelson_or_right_comb _ , [c] -> ok @@ t_michelson_or_right_comb c - | TC_michelson_or_left_comb _ , [c] -> ok @@ t_michelson_or_left_comb c - | _ , _ -> fail @@ bad_type_operator op +let t_function ?loc type1 type2 : type_expression = make_t ?loc @@ T_arrow {type1; type2} +let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map ,[key; value]) +let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map, [key; value]) +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, [t_annoted l l_ann; t_annoted r r_ann]) +let t_michelson_pair ?loc l l_ann r r_ann : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair, [t_annoted l l_ann; t_annoted r r_ann]) +let t_michelson_pair_right_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair_right_comb, [c]) +let t_michelson_pair_left_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_pair_left_comb, [c]) +let t_michelson_or_right_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_or_right_comb, [c]) +let t_michelson_or_left_comb ?loc c : type_expression = make_t ?loc @@ T_operator (TC_michelson_or_left_comb, [c]) + +let get_t_annoted = fun te -> + match te.type_content with + T_annoted (te, lst) -> ok (te,lst) + | _ -> simple_fail "not a T_annoted" let make_e ?(loc = Location.generated) expression_content = let location = loc in diff --git a/src/stages/1-ast_imperative/combinators.mli b/src/stages/1-ast_imperative/combinators.mli index 46e02fa9e..0bb23e660 100644 --- a/src/stages/1-ast_imperative/combinators.mli +++ b/src/stages/1-ast_imperative/combinators.mli @@ -46,11 +46,18 @@ val t_michelson_or : ?loc:Location.t -> type_expression -> michelson_prct_annota 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_michelson_pair_right_comb : ?loc:Location.t -> type_expression -> type_expression +val t_michelson_pair_left_comb : ?loc:Location.t -> type_expression -> type_expression +val t_michelson_or_right_comb : ?loc:Location.t -> type_expression -> type_expression +val t_michelson_or_left_comb : ?loc:Location.t -> type_expression -> type_expression -val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression result +val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression val t_set : ?loc:Location.t -> type_expression -> type_expression val t_contract : ?loc:Location.t -> type_expression -> type_expression +val t_annoted : ?loc:Location.t -> type_expression -> string -> type_expression +val get_t_annoted : type_expression -> (type_expression* string) result + val make_e : ?loc:Location.t -> expression_content -> expression val e_literal : ?loc:Location.t -> literal -> expression diff --git a/src/stages/1-ast_imperative/types.ml b/src/stages/1-ast_imperative/types.ml index 4651c1f9f..877a7cf39 100644 --- a/src/stages/1-ast_imperative/types.ml +++ b/src/stages/1-ast_imperative/types.ml @@ -11,7 +11,8 @@ type type_content = | T_arrow of arrow | T_variable of type_variable | T_constant of type_constant - | T_operator of type_operator + | T_operator of (type_operator * type_expression list) + | T_annoted of (type_expression * string) and arrow = {type1: type_expression; type2: type_expression} @@ -21,20 +22,6 @@ and ctor_content = {ctor_type : type_expression ; ctor_decl_pos : int} and michelson_prct_annotation = string -and type_operator = - | TC_contract of type_expression - | TC_option of type_expression - | TC_list of type_expression - | 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_michelson_pair of type_expression * michelson_prct_annotation * type_expression * michelson_prct_annotation - | TC_michelson_or_right_comb of type_expression - | TC_michelson_or_left_comb of type_expression - | TC_michelson_pair_right_comb of type_expression - | TC_michelson_pair_left_comb of type_expression - 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 3f348c52c..cb48c7ec0 100644 --- a/src/stages/2-ast_sugar/PP.ml +++ b/src/stages/2-ast_sugar/PP.ml @@ -42,20 +42,22 @@ let rec type_expression' : and type_expression ppf (te : type_expression) : unit = type_expression' type_expression ppf te -and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator -> unit = +and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator * type_expression list -> unit = fun f ppf to_ -> - let s = - match to_ with - | TC_option te -> Format.asprintf "option(%a)" f te - | TC_list te -> Format.asprintf "list(%a)" f te - | TC_set te -> Format.asprintf "set(%a)" f te - | 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_contract te -> Format.asprintf "Contract (%a)" f te - | TC_michelson_pair_right_comb c -> Format.asprintf "michelson_pair_right_comb (%a)" f c - | TC_michelson_pair_left_comb c -> Format.asprintf "michelson_pair_left_comb (%a)" f c - | TC_michelson_or_right_comb c -> Format.asprintf "michelson_or_right_comb (%a)" f c - | TC_michelson_or_left_comb c -> Format.asprintf "michelson_or_left_comb (%a)" f c + let s = match to_ with + TC_option , lst -> Format.asprintf "option(%a)" (list_sep_d f) lst + | TC_list , lst -> Format.asprintf "list(%a)" (list_sep_d f) lst + | TC_set , lst -> Format.asprintf "set(%a)" (list_sep_d f) lst + | TC_map , lst -> Format.asprintf "Map (%a)" (list_sep_d f) lst + | TC_big_map , lst -> Format.asprintf "Big Map (%a)" (list_sep_d f) lst + | TC_map_or_big_map , lst -> Format.asprintf "Map Or Big Map (%a)" (list_sep_d f) lst + | TC_contract , lst -> Format.asprintf "Contract (%a)" (list_sep_d f) lst + | TC_michelson_pair , lst -> Format.asprintf "michelson_pair (%a)" (list_sep_d f) lst + | TC_michelson_or , lst -> Format.asprintf "michelson_or (%a)" (list_sep_d f) lst + | TC_michelson_pair_right_comb , lst -> Format.asprintf "michelson_pair_right_comb (%a)" (list_sep_d f) lst + | TC_michelson_pair_left_comb , lst -> Format.asprintf "michelson_pair_left_comb (%a)" (list_sep_d f) lst + | TC_michelson_or_right_comb , lst -> Format.asprintf "michelson_or_right_comb (%a)" (list_sep_d f) lst + | TC_michelson_or_left_comb , lst -> Format.asprintf "michelson_or_left_comb (%a)" (list_sep_d f) lst in fprintf ppf "(TO_%s)" s diff --git a/src/stages/2-ast_sugar/combinators.ml b/src/stages/2-ast_sugar/combinators.ml index 8c8890748..9449b39ad 100644 --- a/src/stages/2-ast_sugar/combinators.ml +++ b/src/stages/2-ast_sugar/combinators.ml @@ -12,10 +12,6 @@ module Errors = struct ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; ] in error ~data title message - let bad_type_operator type_op = - let title () = Format.asprintf "bad type operator %a" (PP.type_operator PP.type_expression) type_op in - let message () = "" in - error title message end open Errors @@ -40,8 +36,8 @@ let t_signature ?loc () : type_expression = make_t ?loc @@ T_constant (TC_sign let t_key ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key) let t_key_hash ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key_hash) let t_timestamp ?loc () : type_expression = make_t ?loc @@ T_constant (TC_timestamp) -let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option o) -let t_list ?loc t : type_expression = make_t ?loc @@ T_operator (TC_list t) +let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option, [o]) +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 @@ -65,21 +61,12 @@ let t_sum ?loc m : type_expression = ez_t_sum ?loc lst let t_function ?loc type1 type2 : type_expression = make_t ?loc @@ T_arrow {type1; type2} -let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map (key, value)) -let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map (key , value)) -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_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map ,[key; value]) +let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map, [key; value]) +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]) -(* TODO find a better way than using list*) -let t_operator ?loc op lst: type_expression result = - match op,lst with - | TC_set _ , [t] -> ok @@ t_set ?loc t - | TC_list _ , [t] -> ok @@ t_list ?loc t - | TC_option _ , [t] -> ok @@ t_option ?loc t - | TC_map (_,_) , [kt;vt] -> ok @@ t_map ?loc kt vt - | TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map ?loc kt vt - | TC_contract _ , [t] -> ok @@ t_contract ?loc t - | _ , _ -> fail @@ bad_type_operator op +let t_operator ?loc op lst: type_expression = make_t ?loc @@ T_operator (op, lst) let make_e ?(loc = Location.generated) expression_content = let location = loc in diff --git a/src/stages/2-ast_sugar/combinators.mli b/src/stages/2-ast_sugar/combinators.mli index 3faebef21..6a229cca8 100644 --- a/src/stages/2-ast_sugar/combinators.mli +++ b/src/stages/2-ast_sugar/combinators.mli @@ -41,9 +41,11 @@ 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 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_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression result +val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression +val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression +val t_big_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression +val t_contract : ?loc:Location.t -> type_expression -> type_expression val t_set : ?loc:Location.t -> type_expression -> type_expression val make_e : ?loc:Location.t -> expression_content -> expression diff --git a/src/stages/2-ast_sugar/types.ml b/src/stages/2-ast_sugar/types.ml index 88df116fb..bdf2f660b 100644 --- a/src/stages/2-ast_sugar/types.ml +++ b/src/stages/2-ast_sugar/types.ml @@ -15,7 +15,7 @@ type type_content = | T_arrow of arrow | T_variable of type_variable | T_constant of type_constant - | T_operator of type_operator + | T_operator of (type_operator * type_expression list) and arrow = {type1: type_expression; type2: type_expression} @@ -23,18 +23,6 @@ and ctor_content = {ctor_type : type_expression ; michelson_annotation : string and field_content = {field_type : type_expression ; michelson_annotation : string option ; field_decl_pos : int} -and type_operator = - | TC_contract of type_expression - | TC_option of type_expression - | TC_list of type_expression - | TC_set of type_expression - | TC_map of type_expression * type_expression - | TC_big_map of type_expression * type_expression - | TC_michelson_pair_right_comb of type_expression - | TC_michelson_pair_left_comb of type_expression - | TC_michelson_or_right_comb of type_expression - | TC_michelson_or_left_comb of type_expression - and type_expression = {type_content: type_content; location: Location.t} diff --git a/src/stages/3-ast_core/combinators.ml b/src/stages/3-ast_core/combinators.ml index e99cac234..cb24f203d 100644 --- a/src/stages/3-ast_core/combinators.ml +++ b/src/stages/3-ast_core/combinators.ml @@ -12,10 +12,6 @@ module Errors = struct ("location" , fun () -> Format.asprintf "%a" Location.pp location) ; ] in error ~data title message - let bad_type_operator type_op = - let title () = Format.asprintf "bad type operator %a" (PP.type_operator PP.type_expression) type_op in - let message () = "" in - error title message end open Errors @@ -40,8 +36,8 @@ let t_signature ?loc () : type_expression = make_t ?loc @@ T_constant (TC_sign let t_key ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key) let t_key_hash ?loc () : type_expression = make_t ?loc @@ T_constant (TC_key_hash) let t_timestamp ?loc () : type_expression = make_t ?loc @@ T_constant (TC_timestamp) -let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option o) -let t_list ?loc t : type_expression = make_t ?loc @@ T_operator (TC_list t) +let t_option ?loc o : type_expression = make_t ?loc @@ T_operator (TC_option, [o]) +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 @@ -63,21 +59,12 @@ let t_sum ?loc m : type_expression = ez_t_sum ?loc lst let t_function ?loc type1 type2 : type_expression = make_t ?loc @@ T_arrow {type1; type2} -let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map (key, value)) -let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map (key , value)) -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) -(* TODO find a better way than using list*) -let t_operator ?loc op lst: type_expression result = - match op,lst with - | TC_set _ , [t] -> ok @@ t_set ?loc t - | TC_list _ , [t] -> ok @@ t_list ?loc t - | TC_option _ , [t] -> ok @@ t_option ?loc t - | TC_map (_,_) , [kt;vt] -> ok @@ t_map kt ?loc vt - | TC_big_map (_,_) , [kt;vt] -> ok @@ t_big_map ?loc kt vt - | TC_contract _ , [t] -> ok @@ t_contract ?loc t - | _ , _ -> fail @@ bad_type_operator op +let t_operator ?loc op lst : type_expression = make_t ?loc @@ T_operator (op, lst) +let t_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_map, [key; value]) +let t_big_map ?loc key value : type_expression = make_t ?loc @@ T_operator (TC_big_map, [key; value]) +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 make_e ?(loc = Location.generated) expression_content = { expression_content; location=loc } diff --git a/src/stages/3-ast_core/combinators.mli b/src/stages/3-ast_core/combinators.mli index a271991da..550f87883 100644 --- a/src/stages/3-ast_core/combinators.mli +++ b/src/stages/3-ast_core/combinators.mli @@ -41,9 +41,11 @@ val t_sum : ?loc:Location.t -> Types.ctor_content Map.String.t -> type_expres val ez_t_sum : ?loc:Location.t -> ( string * Types.ctor_content ) list -> type_expression 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_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression result +val t_operator : ?loc:Location.t -> type_operator -> type_expression list -> type_expression +val t_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression +val t_big_map : ?loc:Location.t -> type_expression -> type_expression -> type_expression +val t_contract : ?loc:Location.t -> type_expression -> type_expression val t_set : ?loc:Location.t -> type_expression -> type_expression val make_e : ?loc:Location.t -> expression_content -> expression diff --git a/src/stages/common/PP.ml b/src/stages/common/PP.ml index 579c2a327..2a02fa4e0 100644 --- a/src/stages/common/PP.ml +++ b/src/stages/common/PP.ml @@ -239,25 +239,22 @@ module Ast_PP_type (PARAMETER : AST_PARAMETER_TYPE) = struct and type_expression ppf (te : type_expression) : unit = type_expression' type_expression ppf te - and type_operator : - (formatter -> type_expression -> unit) - -> formatter - -> type_operator - -> unit = + and type_operator : (formatter -> type_expression -> unit) -> formatter -> type_operator * type_expression list -> unit = fun f ppf to_ -> - let s = - match to_ with - | TC_option te -> Format.asprintf "option(%a)" f te - | TC_list te -> Format.asprintf "list(%a)" f te - | TC_set te -> Format.asprintf "set(%a)" f te - | 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_map_or_big_map (k, v) -> Format.asprintf "Map Or Big Map (%a,%a)" f k f v - | TC_contract te -> Format.asprintf "Contract (%a)" f te - | TC_michelson_pair_right_comb c -> Format.asprintf "michelson_pair_right_comb (%a)" f c - | TC_michelson_pair_left_comb c -> Format.asprintf "michelson_pair_left_comb (%a)" f c - | TC_michelson_or_right_comb c -> Format.asprintf "michelson_or_right_comb (%a)" f c - | TC_michelson_or_left_comb c -> Format.asprintf "michelson_or_left_comb (%a)" f c + let s = match to_ with + TC_option , lst -> Format.asprintf "option(%a)" (list_sep_d f) lst + | TC_list , lst -> Format.asprintf "list(%a)" (list_sep_d f) lst + | TC_set , lst -> Format.asprintf "set(%a)" (list_sep_d f) lst + | TC_map , lst -> Format.asprintf "Map (%a)" (list_sep_d f) lst + | TC_big_map , lst -> Format.asprintf "Big Map (%a)" (list_sep_d f) lst + | TC_map_or_big_map , lst -> Format.asprintf "Map Or Big Map (%a)" (list_sep_d f) lst + | TC_contract , lst -> Format.asprintf "Contract (%a)" (list_sep_d f) lst + | TC_michelson_pair , lst -> Format.asprintf "michelson_pair (%a)" (list_sep_d f) lst + | TC_michelson_or , lst -> Format.asprintf "michelson_or (%a)" (list_sep_d f) lst + | TC_michelson_pair_right_comb , lst -> Format.asprintf "michelson_pair_right_comb (%a)" (list_sep_d f) lst + | TC_michelson_pair_left_comb , lst -> Format.asprintf "michelson_pair_left_comb (%a)" (list_sep_d f) lst + | TC_michelson_or_right_comb , lst -> Format.asprintf "michelson_or_right_comb (%a)" (list_sep_d f) lst + | TC_michelson_or_left_comb , lst -> Format.asprintf "michelson_or_left_comb (%a)" (list_sep_d f) lst in fprintf ppf "(type_operator: %s)" s end diff --git a/src/stages/common/types.ml b/src/stages/common/types.ml index cfa765fa8..01b657289 100644 --- a/src/stages/common/types.ml +++ b/src/stages/common/types.ml @@ -29,6 +29,21 @@ type 'a constructor_map = 'a CMap.t | TC_signature | TC_timestamp | TC_void + and type_operator = + | TC_contract + | TC_option + | TC_list + | TC_set + | TC_map + | TC_big_map + | TC_map_or_big_map + | TC_michelson_pair + | TC_michelson_or + | TC_michelson_pair_right_comb + | TC_michelson_pair_left_comb + | TC_michelson_or_right_comb + | TC_michelson_or_left_comb + module type AST_PARAMETER_TYPE = sig type type_meta end @@ -44,7 +59,7 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct | T_arrow of arrow | T_variable of type_variable | T_constant of type_constant - | T_operator of type_operator + | T_operator of (type_operator * type_expression list) and arrow = {type1: type_expression; type2: type_expression} @@ -52,69 +67,32 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct and field_content = {field_type : type_expression ; field_annotation : string option ; field_decl_pos : int} - and type_operator = - | TC_contract of type_expression - | TC_option of type_expression - | TC_list of type_expression - | TC_set of type_expression - | TC_map of type_expression * type_expression - | TC_big_map of type_expression * type_expression - | TC_map_or_big_map of type_expression * type_expression - | TC_michelson_pair_right_comb of type_expression - | TC_michelson_pair_left_comb of type_expression - | TC_michelson_or_right_comb of type_expression - | TC_michelson_or_left_comb of type_expression - and type_expression = {type_content: type_content; location: Location.t; type_meta: type_meta} open Trace - let map_type_operator f = function - TC_contract x -> TC_contract (f x) - | TC_option x -> TC_option (f x) - | TC_list x -> TC_list (f x) - | TC_set x -> TC_set (f x) - | TC_map (x , y) -> TC_map (f x , f y) - | TC_big_map (x , y)-> TC_big_map (f x , f y) - | TC_map_or_big_map (x , y)-> TC_map_or_big_map (f x , f y) - | TC_michelson_pair_right_comb c -> TC_michelson_pair_right_comb (f c) - | TC_michelson_pair_left_comb c -> TC_michelson_pair_left_comb (f c) - | TC_michelson_or_right_comb c -> TC_michelson_or_right_comb (f c) - | TC_michelson_or_left_comb c -> TC_michelson_or_left_comb (f c) - - let bind_map_type_operator f = function - TC_contract x -> let%bind x = f x in ok @@ TC_contract x - | TC_option x -> let%bind x = f x in ok @@ TC_option x - | TC_list x -> let%bind x = f x in ok @@ TC_list x - | TC_set x -> let%bind x = f x in ok @@ TC_set x - | TC_map (x , y) -> let%bind x = f x in let%bind y = f y in ok @@ TC_map (x , y) - | TC_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_big_map (x , y) - | TC_map_or_big_map (x , y)-> let%bind x = f x in let%bind y = f y in ok @@ TC_map_or_big_map (x , y) - | TC_michelson_pair_right_comb c -> let%bind c = f c in ok @@ TC_michelson_pair_right_comb c - | TC_michelson_pair_left_comb c -> let%bind c = f c in ok @@ TC_michelson_pair_left_comb c - | TC_michelson_or_right_comb c -> let%bind c = f c in ok @@ TC_michelson_or_right_comb c - | TC_michelson_or_left_comb c -> let%bind c = f c in ok @@ TC_michelson_or_left_comb c - let type_operator_name = function - TC_contract _ -> "TC_contract" - | TC_option _ -> "TC_option" - | TC_list _ -> "TC_list" - | TC_set _ -> "TC_set" - | TC_map _ -> "TC_map" - | TC_big_map _ -> "TC_big_map" - | TC_map_or_big_map _ -> "TC_map_or_big_map" - | TC_michelson_pair_right_comb _ -> "TC_michelson_pair_right_comb" - | TC_michelson_pair_left_comb _ -> "TC_michelson_pair_left_comb" - | TC_michelson_or_right_comb _ -> "TC_michelson_or_right_comb" - | TC_michelson_or_left_comb _ -> "TC_michelson_or_left_comb" + TC_contract -> "TC_contract" + | TC_option -> "TC_option" + | TC_list -> "TC_list" + | TC_set -> "TC_set" + | TC_map -> "TC_map" + | TC_big_map -> "TC_big_map" + | TC_map_or_big_map -> "TC_map_or_big_map" + | TC_michelson_pair -> "TC_michelson_pair" + | TC_michelson_or -> "TC_michelson_or" + | TC_michelson_pair_right_comb -> "TC_michelson_pair_right_comb" + | TC_michelson_pair_left_comb -> "TC_michelson_pair_left_comb" + | TC_michelson_or_right_comb -> "TC_michelson_or_right_comb" + | TC_michelson_or_left_comb -> "TC_michelson_or_left_comb" let type_expression'_of_string = function - | "TC_contract" , [x] -> ok @@ T_operator(TC_contract x) - | "TC_option" , [x] -> ok @@ T_operator(TC_option x) - | "TC_list" , [x] -> ok @@ T_operator(TC_list x) - | "TC_set" , [x] -> ok @@ T_operator(TC_set x) - | "TC_map" , [x ; y] -> ok @@ T_operator(TC_map (x , y)) - | "TC_big_map" , [x ; y] -> ok @@ T_operator(TC_big_map (x, y)) + | "TC_contract" , [x] -> ok @@ T_operator(TC_contract, [x]) + | "TC_option" , [x] -> ok @@ T_operator(TC_option, [x]) + | "TC_list" , [x] -> ok @@ T_operator(TC_list, [x]) + | "TC_set" , [x] -> ok @@ T_operator(TC_set, [x]) + | "TC_map" , [x ; y] -> ok @@ T_operator(TC_map, [x ; y]) + | "TC_big_map" , [x ; y] -> ok @@ T_operator(TC_big_map, [x; y]) | ("TC_contract" | "TC_option" | "TC_list" | "TC_set" | "TC_map" | "TC_big_map"), _ -> failwith "internal error: wrong number of arguments for type operator" @@ -137,17 +115,19 @@ module Ast_generic_type (PARAMETER : AST_PARAMETER_TYPE) = struct failwith "internal error: unknown type operator" let string_of_type_operator = function - | TC_contract x -> "TC_contract" , [x] - | TC_option x -> "TC_option" , [x] - | TC_list x -> "TC_list" , [x] - | TC_set x -> "TC_set" , [x] - | TC_map (x , y) -> "TC_map" , [x ; y] - | TC_big_map (x , y) -> "TC_big_map" , [x ; y] - | TC_map_or_big_map (x , y) -> "TC_map_or_big_map" , [x ; y] - | TC_michelson_pair_right_comb c -> "TC_michelson_pair_right_comb" , [c] - | TC_michelson_pair_left_comb c -> "TC_michelson_pair_left_comb" , [c] - | TC_michelson_or_right_comb c -> "TC_michelson_or_right_comb" , [c] - | TC_michelson_or_left_comb c -> "TC_michelson_or_left_comb" , [c] + | TC_contract , lst -> "TC_contract" , lst + | TC_option , lst -> "TC_option" , lst + | TC_list , lst -> "TC_list" , lst + | TC_set , lst -> "TC_set" , lst + | TC_map , lst -> "TC_map" , lst + | TC_big_map , lst -> "TC_big_map" , lst + | TC_map_or_big_map , lst -> "TC_map_or_big_map" , lst + | TC_michelson_pair , lst -> "TC_michelson_pair" , lst + | TC_michelson_or , lst -> "TC_michelson_or" , lst + | TC_michelson_pair_right_comb , lst -> "TC_michelson_pair_right_comb" , lst + | TC_michelson_pair_left_comb , lst -> "TC_michelson_pair_left_comb" , lst + | TC_michelson_or_right_comb , lst -> "TC_michelson_or_right_comb" , lst + | TC_michelson_or_left_comb , lst -> "TC_michelson_or_left_comb" , lst let string_of_type_constant = function | TC_unit -> "TC_unit", [] diff --git a/src/stages/typesystem/misc.ml b/src/stages/typesystem/misc.ml index c42040854..4ed67fa91 100644 --- a/src/stages/typesystem/misc.ml +++ b/src/stages/typesystem/misc.ml @@ -91,13 +91,12 @@ module Substitution = struct | Ast_core.T_record _ -> failwith "TODO: subst: unimplemented case s_type_expression record" | Ast_core.T_arrow _ -> failwith "TODO: subst: unimplemented case s_type_expression arrow" | Ast_core.T_variable _ -> failwith "TODO: subst: unimplemented case s_type_expression variable" - | Ast_core.T_operator op -> - let%bind op = - Ast_core.bind_map_type_operator + | Ast_core.T_operator (op,lst) -> + let%bind lst = bind_map_list (s_abstr_type_expression ~substs) - op in + lst in (* TODO: when we have generalized operators, we might need to subst the operator name itself? *) - ok @@ Ast_core.T_operator op + ok @@ Ast_core.T_operator (op, lst) | Ast_core.T_constant constant -> ok @@ Ast_core.T_constant constant