From 54663766c2fa0070f9aa1361190792d44b8b1ec9 Mon Sep 17 00:00:00 2001
From: Dan Korostelev <nadako@gmail.com>
Date: Fri, 6 Oct 2017 02:03:26 +0300
Subject: [PATCH] add new function type syntax (closes #4799)
---
src/core/ast.ml | 6 +-
src/macro/macroApi.ml | 4 +
src/syntax/grammar.mly | 110 ++++++++++++++++--------
src/syntax/reification.ml | 1 +
src/typing/typeload.ml | 4 +-
std/haxe/macro/Expr.hx | 5 ++
std/haxe/macro/Printer.hx | 1 +
tests/unit/src/unit/HelperMacros.hx | 6 ++
tests/unit/src/unit/issues/Issue2958.hx | 9 +-
tests/unit/src/unit/issues/Issue4799.hx | 29 +++++++
10 files changed, 128 insertions(+), 47 deletions(-)
create mode 100644 tests/unit/src/unit/issues/Issue4799.hx
diff --git a/src/core/ast.ml b/src/core/ast.ml
index 745320c981c..d63858cbc2b 100644
--- a/src/core/ast.ml
+++ b/src/core/ast.ml
@@ -161,6 +161,7 @@ and complex_type =
| CTParent of type_hint
| CTExtend of placed_type_path list * class_field list
| CTOptional of type_hint
+ | CTNamed of placed_name * type_hint
and type_hint = complex_type * pos
@@ -559,7 +560,9 @@ let map_expr loop (e,p) =
let tl = List.map tpath tl in
let fl = List.map cfield fl in
CTExtend (tl,fl)
- | CTOptional t -> CTOptional (type_hint t)),p
+ | CTOptional t -> CTOptional (type_hint t)
+ | CTNamed (n,t) -> CTNamed (n,type_hint t)
+ ),p
and tparamdecl t =
let constraints = List.map type_hint t.tp_constraints in
let params = List.map tparamdecl t.tp_params in
@@ -757,6 +760,7 @@ let s_expr e =
| CTAnonymous fl -> "{ " ^ String.concat "; " (List.map (s_class_field tabs) fl) ^ "}";
| CTParent(t,_) -> "(" ^ s_complex_type tabs t ^ ")"
| CTOptional(t,_) -> "?" ^ s_complex_type tabs t
+ | CTNamed((n,_),(t,_)) -> n ^ ":" ^ s_complex_type tabs t
| CTExtend (tl, fl) -> "{> " ^ String.concat " >, " (List.map (s_complex_type_path tabs) tl) ^ ", " ^ String.concat ", " (List.map (s_class_field tabs) fl) ^ " }"
and s_class_field tabs f =
match f.cff_doc with
diff --git a/src/macro/macroApi.ml b/src/macro/macroApi.ml
index 87fec9cad19..19c2dd6c757 100644
--- a/src/macro/macroApi.ml
+++ b/src/macro/macroApi.ml
@@ -433,6 +433,8 @@ and encode_ctype t =
4, [encode_array (List.map encode_path tl); encode_array (List.map encode_field fields)]
| CTOptional t ->
5, [encode_ctype t]
+ | CTNamed (n,t) ->
+ 6, [encode_placed_name n; encode_ctype t]
in
encode_enum ~pos:(Some (pos t)) ICType tag pl
@@ -732,6 +734,8 @@ and decode_ctype t =
CTExtend (List.map decode_path (decode_array tl), List.map decode_field (decode_array fl))
| 5, [t] ->
CTOptional (decode_ctype t)
+ | 6, [n;t] ->
+ CTNamed ((decode_string n,p), decode_ctype t)
| _ ->
raise Invalid_expr),p
diff --git a/src/syntax/grammar.mly b/src/syntax/grammar.mly
index bcaeabc5035..53f50371cfe 100644
--- a/src/syntax/grammar.mly
+++ b/src/syntax/grammar.mly
@@ -377,15 +377,31 @@ and parse_type_opt = parser
| [< t = parse_type_hint >] -> Some t
| [< >] -> None
-and parse_complex_type s =
- let t = parse_complex_type_inner s in
- parse_complex_type_next t s
+and parse_complex_type s = parse_complex_type_maybe_named false s
+
+and parse_complex_type_maybe_named allow_named = parser
+ | [< '(POpen,p1); tl = psep Comma (parse_complex_type_maybe_named true); '(PClose,p2); s >] ->
+ begin match tl with
+ | [] | [(CTNamed _,_)] ->
+ (* it was () or (a:T) - clearly a new function type syntax, proceed with parsing return type *)
+ parse_function_type_next tl p1 s
+ | [t] ->
+ (* it was some single unnamed type in parenthesis - use old function type syntax *)
+ let t = CTParent t,punion p1 p2 in
+ parse_complex_type_next t s
+ | _ ->
+ (* it was multiple arguments - clearly a new function type syntax, proceed with parsing return type *)
+ parse_function_type_next tl p1 s
+ end
+ | [< s >] ->
+ let t = parse_complex_type_inner allow_named s in
+ parse_complex_type_next t s
and parse_structural_extension = parser
| [< '(Binop OpGt,_); t = parse_type_path; '(Comma,_); s >] ->
t
-and parse_complex_type_inner = parser
+and parse_complex_type_inner allow_named = parser
| [< '(POpen,p1); t = parse_complex_type; '(PClose,p2) >] -> CTParent t,punion p1 p2
| [< '(BrOpen,p1); s >] ->
(match s with parser
@@ -397,8 +413,18 @@ and parse_complex_type_inner = parser
| [< l,p2 = parse_class_fields true p1 >] -> CTExtend (tl,l),punion p1 p2)
| [< l,p2 = parse_class_fields true p1 >] -> CTAnonymous l,punion p1 p2
| [< >] -> serror())
- | [< '(Question,p1); t,p2 = parse_complex_type_inner >] ->
+ | [< '(Question,p1); t,p2 = parse_complex_type_inner allow_named >] ->
CTOptional (t,p2),punion p1 p2
+ | [< n = dollar_ident; s >] ->
+ (match s with parser
+ | [< '(DblDot,_) when allow_named; t = parse_complex_type >] ->
+ let p1 = snd n in
+ let p2 = snd t in
+ CTNamed (n,t),punion p1 p2
+ | [< s >] ->
+ let n,p = n in
+ let t,p = parse_type_path2 None [] n p s in
+ CTPath t,p)
| [< t,p = parse_type_path >] ->
CTPath t,p
@@ -406,42 +432,45 @@ and parse_type_path s = parse_type_path1 None [] s
and parse_type_path1 p0 pack = parser
| [< name, p1 = dollar_ident_macro pack; s >] ->
- if is_lower_ident name then
- (match s with parser
- | [< '(Dot,p) >] ->
- if is_resuming p then
- raise (TypePath (List.rev (name :: pack),None,false))
- else
- parse_type_path1 (match p0 with None -> Some p1 | Some _ -> p0) (name :: pack) s
- | [< '(Semicolon,_) >] ->
- error (Custom "Type name should start with an uppercase letter") p1
- | [< >] -> serror())
- else
- let sub,p2 = (match s with parser
- | [< '(Dot,p); s >] ->
- (if is_resuming p then
- raise (TypePath (List.rev pack,Some (name,false),false))
- else match s with parser
- | [< '(Const (Ident name),p2) when not (is_lower_ident name) >] -> Some name,p2
- | [< '(Binop OpOr,_) when do_resume() >] ->
- set_resume p;
- raise (TypePath (List.rev pack,Some (name,false),false))
- | [< >] -> serror())
- | [< >] -> None,p1
- ) in
- let params,p2 = (match s with parser
- | [< '(Binop OpLt,_); l = psep Comma parse_type_path_or_const; '(Binop OpGt,p2) >] -> l,p2
- | [< >] -> [],p2
- ) in
- {
- tpackage = List.rev pack;
- tname = name;
- tparams = params;
- tsub = sub;
- },punion (match p0 with None -> p1 | Some p -> p) p2
+ parse_type_path2 p0 pack name p1 s
| [< '(Binop OpOr,_) when do_resume() >] ->
raise (TypePath (List.rev pack,None,false))
+and parse_type_path2 p0 pack name p1 s =
+ if is_lower_ident name then
+ (match s with parser
+ | [< '(Dot,p) >] ->
+ if is_resuming p then
+ raise (TypePath (List.rev (name :: pack),None,false))
+ else
+ parse_type_path1 (match p0 with None -> Some p1 | Some _ -> p0) (name :: pack) s
+ | [< '(Semicolon,_) >] ->
+ error (Custom "Type name should start with an uppercase letter") p1
+ | [< >] -> serror())
+ else
+ let sub,p2 = (match s with parser
+ | [< '(Dot,p); s >] ->
+ (if is_resuming p then
+ raise (TypePath (List.rev pack,Some (name,false),false))
+ else match s with parser
+ | [< '(Const (Ident name),p2) when not (is_lower_ident name) >] -> Some name,p2
+ | [< '(Binop OpOr,_) when do_resume() >] ->
+ set_resume p;
+ raise (TypePath (List.rev pack,Some (name,false),false))
+ | [< >] -> serror())
+ | [< >] -> None,p1
+ ) in
+ let params,p2 = (match s with parser
+ | [< '(Binop OpLt,_); l = psep Comma parse_type_path_or_const; '(Binop OpGt,p2) >] -> l,p2
+ | [< >] -> [],p2
+ ) in
+ {
+ tpackage = List.rev pack;
+ tname = name;
+ tparams = params;
+ tsub = sub;
+ },punion (match p0 with None -> p1 | Some p -> p) p2
+
and type_name = parser
| [< '(Const (Ident name),p) >] ->
if is_lower_ident name then
@@ -467,6 +496,11 @@ and parse_complex_type_next (t : type_hint) = parser
CTFunction ([t] , (t2,p2)),punion (pos t) p2)
| [< >] -> t
+and parse_function_type_next tl p1 = parser
+ | [< '(Arrow,_); tret = parse_complex_type_inner false >] ->
+ CTFunction (tl,tret), punion p1 (snd tret)
+ | [< >] -> serror ()
+
and parse_type_anonymous opt final = parser
| [< '(Question,_) when not opt; s >] -> parse_type_anonymous true final s
| [< '(Kwd Final,_) when not opt && not final; s >] -> parse_type_anonymous opt true s
diff --git a/src/syntax/reification.ml b/src/syntax/reification.ml
index 52c4ad45c9b..13ca8d75bed 100644
--- a/src/syntax/reification.ml
+++ b/src/syntax/reification.ml
@@ -136,6 +136,7 @@ let reify in_macro =
| CTParent t -> ct "TParent" [to_type_hint t p]
| CTExtend (tl,fields) -> ct "TExtend" [to_array to_tpath tl p; to_array to_cfield fields p]
| CTOptional t -> ct "TOptional" [to_type_hint t p]
+ | CTNamed (n,t) -> ct "TNamed" [to_placed_name n; to_type_hint t p]
and to_type_hint (t,p) _ =
(* to_obj ["type",to_ctype t p;"pos",to_pos p] p *)
to_ctype (t,p) p
diff --git a/src/typing/typeload.ml b/src/typing/typeload.ml
index c2beadb83fe..b3a14cf5644 100644
--- a/src/typing/typeload.ml
+++ b/src/typing/typeload.ml
@@ -546,6 +546,7 @@ and load_complex_type ctx allow_display p (t,pn) =
| CTParent t -> load_complex_type ctx allow_display p t
| CTPath t -> load_instance ~allow_display ctx (t,pn) false p
| CTOptional _ -> error "Optional type not allowed here" p
+ | CTNamed _ -> error "Named type not allowed here" p
| CTExtend (tl,l) ->
(match load_complex_type ctx allow_display p (CTAnonymous l,p) with
| TAnon a as ta ->
@@ -685,7 +686,8 @@ and load_complex_type ctx allow_display p (t,pn) =
| _ ->
TFun (List.map (fun t ->
let t, opt = (match fst t with CTOptional t -> t, true | _ -> t,false) in
- "",opt,load_complex_type ctx allow_display p t
+ let n,t = (match fst t with CTNamed (n,t) -> (fst n), t | _ -> "", t) in
+ n,opt,load_complex_type ctx allow_display p t
) args,load_complex_type ctx allow_display p r)
and init_meta_overloads ctx co cf =
diff --git a/std/haxe/macro/Expr.hx b/std/haxe/macro/Expr.hx
index f0ce9a13453..ff54336cf9f 100644
--- a/std/haxe/macro/Expr.hx
+++ b/std/haxe/macro/Expr.hx
@@ -570,6 +570,11 @@ enum ComplexType {
Represents an optional type.
**/
TOptional( t : ComplexType );
+
+ /**
+ Represents a type with a name.
+ **/
+ TNamed( n : String, t : ComplexType );
}
/**
diff --git a/std/haxe/macro/Printer.hx b/std/haxe/macro/Printer.hx
index 88181cba4bb..ccf8cdc912b 100644
--- a/std/haxe/macro/Printer.hx
+++ b/std/haxe/macro/Printer.hx
@@ -120,6 +120,7 @@ class Printer {
case TAnonymous(fields): "{ " + [for (f in fields) printField(f) + "; "].join("") + "}";
case TParent(ct): "(" + printComplexType(ct) + ")";
case TOptional(ct): "?" + printComplexType(ct);
+ case TNamed(n,ct): n + ":" + printComplexType(ct);
case TExtend(tpl, fields): '{> ${tpl.map(printTypePath).join(" >, ")}, ${fields.map(printField).join(", ")} }';
}
diff --git a/tests/unit/src/unit/HelperMacros.hx b/tests/unit/src/unit/HelperMacros.hx
index 1876ca8ebc1..4259a0f6df7 100644
--- a/tests/unit/src/unit/HelperMacros.hx
+++ b/tests/unit/src/unit/HelperMacros.hx
@@ -7,6 +7,12 @@ class HelperMacros {
return macro $v { Std.string(Date.now()) };
}
+ static public macro function typeString(e) {
+ var typed = haxe.macro.Context.typeExpr(e);
+ var s = haxe.macro.TypeTools.toString(typed.t);
+ return macro $v{s};
+ }
+
static public macro function typedAs(actual:haxe.macro.Expr, expected:haxe.macro.Expr) {
var tExpected = haxe.macro.Context.typeof(expected);
var tActual = haxe.macro.Context.typeof(actual);
diff --git a/tests/unit/src/unit/issues/Issue2958.hx b/tests/unit/src/unit/issues/Issue2958.hx
index 96450984181..7afc365c18b 100644
--- a/tests/unit/src/unit/issues/Issue2958.hx
+++ b/tests/unit/src/unit/issues/Issue2958.hx
@@ -1,5 +1,7 @@
package unit.issues;
+import unit.HelperMacros.typeString;
+
private typedef Asset<@:const T> = String;
class Issue2958 extends Test {
@@ -9,11 +11,4 @@ class Issue2958 extends Test {
"unit.issues._Issue2958.Asset<[\"test\", 1]>"
);
}
-
- static macro function typeString(e)
- {
- var typed = haxe.macro.Context.typeExpr(e);
- var s = haxe.macro.TypeTools.toString(typed.t);
- return macro $v{s};
- }
}
\ No newline at end of file
diff --git a/tests/unit/src/unit/issues/Issue4799.hx b/tests/unit/src/unit/issues/Issue4799.hx
new file mode 100644
index 00000000000..3627947bf2f
--- /dev/null
+++ b/tests/unit/src/unit/issues/Issue4799.hx
@@ -0,0 +1,29 @@
+package unit.issues;
+
+import unit.HelperMacros.typeString;
+
+class Issue4799 extends Test {
+ function test() {
+ eq(typeString((null : Int)), "Int");
+ eq(typeString((null : (Int))), "Int");
+ eq(typeString((null : (Int,Int)->Int)), "Int -> Int -> Int");
+ eq(typeString((null : (a:Int,Int)->Int)), "a : Int -> Int -> Int");
+ eq(typeString((null : (a:Int, b:Int)->Int)), "a : Int -> b : Int -> Int");
+ eq(typeString((null : (a:Int, Int, ?String->Void, ?b:(Int->Int)->Int, c:(a:Int)->Void)->Int)),
+ "a : Int -> Int -> (?String -> Void) -> ?b : ((Int -> Int) -> Int) -> c : (a : Int -> Void) -> Int");
+ t(parseError("(Int,Int)->Int->Int"));
+ t(parseError("(a:Int)->Int->Int"));
+ eq(typeString((null : (Int,Int)->(Int->Int))), "Int -> Int -> (Int -> Int)");
+ eq(typeString((null : (a:Int)->(Int->Int))), "a : Int -> (Int -> Int)");
+ }
+
+ static macro function parseError(s:String) {
+ var s = "(null : " + s + ")";
+ try {
+ haxe.macro.Context.parseInlineString(s, haxe.macro.Context.currentPos());
+ return macro false;
+ } catch (e:Any) {
+ return macro true;
+ }
+ }
+}