From 606d5c79842980eea6d1d4d265a991828ae31cfe Mon Sep 17 00:00:00 2001 From: Simon Krajewski Date: Thu, 12 Dec 2013 08:28:45 +0100 Subject: [PATCH] allow multiple structural extension (closes #2364) --- ast.ml | 4 ++-- doc/CHANGES.txt | 2 ++ interp.ml | 8 ++++---- parser.ml | 16 ++++++++++------ std/haxe/macro/Expr.hx | 2 +- std/haxe/macro/Printer.hx | 2 +- typeload.ml | 26 ++++++++++++++++++++------ 7 files changed, 40 insertions(+), 20 deletions(-) diff --git a/ast.ml b/ast.ml index 9b2ae6d9898..aa97bc313e2 100755 --- a/ast.ml +++ b/ast.ml @@ -283,7 +283,7 @@ and complex_type = | CTFunction of complex_type list * complex_type | CTAnonymous of class_field list | CTParent of complex_type - | CTExtend of type_path * class_field list + | CTExtend of type_path list * class_field list | CTOptional of complex_type and func = { @@ -644,7 +644,7 @@ let map_expr loop (e,p) = | CTFunction (cl,c) -> CTFunction (List.map ctype cl, ctype c) | CTAnonymous fl -> CTAnonymous (List.map cfield fl) | CTParent t -> CTParent (ctype t) - | CTExtend (t,fl) -> CTExtend (tpath t, List.map cfield fl) + | CTExtend (tl,fl) -> CTExtend (List.map tpath tl, List.map cfield fl) | CTOptional t -> CTOptional (ctype t) and tparamdecl t = { tp_name = t.tp_name; tp_constraints = List.map ctype t.tp_constraints; tp_params = List.map tparamdecl t.tp_params } diff --git a/doc/CHANGES.txt b/doc/CHANGES.txt index 4d5b5d240f4..bd3d03823bc 100644 --- a/doc/CHANGES.txt +++ b/doc/CHANGES.txt @@ -21,6 +21,7 @@ all : added haxe.xml.Printer all : added haxe.Int32 as abstract type all : improved inline constructors by detecting more cases where it can be applied + all : allow multiple structural extension using { > T1, > T2, fields } js : window and console are reserved words. Access them with __js__ instead of untyped. js : added -D js-flatten js : improved inlining @@ -32,6 +33,7 @@ macro : resolve error line number in external files macro : rewrote macros used as static extension macro : exposed typed AST + macro : [breaking] first argument of ComplexType.TExtend is now Array instead of TypePath flash : fixed font embedding with UTF8 chars flash : give error if non-nullable basic types are skipped in a call diff --git a/interp.ml b/interp.ml index 66538c9da8b..6622cbe9f5a 100644 --- a/interp.ml +++ b/interp.ml @@ -3728,8 +3728,8 @@ and encode_ctype t = 2, [enc_array (List.map encode_field fl)] | CTParent t -> 3, [encode_ctype t] - | CTExtend (t,fields) -> - 4, [encode_path t; enc_array (List.map encode_field fields)] + | CTExtend (tl,fields) -> + 4, [enc_array (List.map encode_path tl); enc_array (List.map encode_field fields)] | CTOptional t -> 5, [encode_ctype t] in @@ -4027,8 +4027,8 @@ and decode_ctype t = CTAnonymous (List.map decode_field (dec_array fl)) | 3, [t] -> CTParent (decode_ctype t) - | 4, [t;fl] -> - CTExtend (decode_path t, List.map decode_field (dec_array fl)) + | 4, [tl;fl] -> + CTExtend (List.map decode_path (dec_array tl), List.map decode_field (dec_array fl)) | 5, [t] -> CTOptional (decode_ctype t) | _ -> diff --git a/parser.ml b/parser.ml index 0fa16b0832e..852e5fa743a 100755 --- a/parser.ml +++ b/parser.ml @@ -230,7 +230,7 @@ let reify in_macro = | CTFunction (args,ret) -> ct "TFunction" [to_array to_ctype args p; to_ctype ret p] | CTAnonymous fields -> ct "TAnonymous" [to_array to_cfield fields p] | CTParent t -> ct "TParent" [to_ctype t p] - | CTExtend (t,fields) -> ct "TExtend" [to_tpath t p; to_array to_cfield fields p] + | CTExtend (tl,fields) -> ct "TExtend" [to_array to_tpath tl p; to_array to_cfield fields p] | CTOptional t -> ct "TOptional" [to_ctype t p] and to_fun f p = let farg (n,o,t,e) p = @@ -765,16 +765,20 @@ and parse_complex_type s = let t = parse_complex_type_inner 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 | [< '(POpen,_); t = parse_complex_type; '(PClose,_) >] -> CTParent t | [< '(BrOpen,p1); s >] -> (match s with parser | [< l = parse_type_anonymous false >] -> CTAnonymous l - | [< '(Binop OpGt,_); t = parse_type_path; '(Comma,_); s >] -> + | [< t = parse_structural_extension; s>] -> + let tl = t :: plist parse_structural_extension s in (match s with parser - | [< l = parse_type_anonymous false >] -> CTExtend (t,l) - | [< l, _ = parse_class_fields true p1 >] -> CTExtend (t,l) - | [< >] -> serror()) + | [< l = parse_type_anonymous false >] -> CTExtend (tl,l) + | [< l, _ = parse_class_fields true p1 >] -> CTExtend (tl,l)) | [< l, _ = parse_class_fields true p1 >] -> CTAnonymous l | [< >] -> serror()) | [< '(Question,_); t = parse_complex_type_inner >] -> @@ -1264,7 +1268,7 @@ and parse_switch_cases eswitch cases = parser | [< '(Kwd Case,p1); el = psep Comma expr; eg = popt parse_guard; '(DblDot,_); s >] -> (match el with | [] -> error (Custom "case without a pattern is not allowed") p1 - | _ -> + | _ -> let b = (try block [] s with Display e -> display (ESwitch (eswitch,List.rev ((el,eg,Some e) :: cases),None),punion (pos eswitch) (pos e))) in let b = match b with | [] -> None diff --git a/std/haxe/macro/Expr.hx b/std/haxe/macro/Expr.hx index 3069f57b053..f5fc2a2f41d 100644 --- a/std/haxe/macro/Expr.hx +++ b/std/haxe/macro/Expr.hx @@ -231,7 +231,7 @@ enum ComplexType { TFunction( args : Array, ret : ComplexType ); TAnonymous( fields : Array ); TParent( t : ComplexType ); - TExtend( p : TypePath, fields : Array ); + TExtend( p : Array, fields : Array ); TOptional( t : ComplexType ); } diff --git a/std/haxe/macro/Printer.hx b/std/haxe/macro/Printer.hx index 1d7decc0a2b..aa86f123d84 100644 --- a/std/haxe/macro/Printer.hx +++ b/std/haxe/macro/Printer.hx @@ -99,7 +99,7 @@ class Printer { case TAnonymous(fields): "{ " + [for (f in fields) printField(f) + "; "].join("") + "}"; case TParent(ct): "(" + printComplexType(ct) + ")"; case TOptional(ct): "?" + printComplexType(ct); - case TExtend(tp, fields): '{${printTypePath(tp)} >, ${fields.map(printField).join(", ")} }'; + case TExtend(tpl, fields): '{${tpl.map(printTypePath).join(", ")} >, ${fields.map(printField).join(", ")} }'; } public function printMetadata(meta:MetadataEntry) return diff --git a/typeload.ml b/typeload.ml index 67a6b258c35..477e881f040 100644 --- a/typeload.ml +++ b/typeload.ml @@ -419,10 +419,10 @@ and load_complex_type ctx p t = | CTParent t -> load_complex_type ctx p t | CTPath t -> load_instance ctx t p false | CTOptional _ -> error "Optional type not allowed here" p - | CTExtend (t,l) -> + | CTExtend (tl,l) -> (match load_complex_type ctx p (CTAnonymous l) with - | TAnon a -> - let rec loop t = + | TAnon a as ta -> + let mk_extension t = match follow t with | TInst ({cl_kind = KTypeParameter _},_) -> error "Cannot structurally extend type parameters" p @@ -445,17 +445,31 @@ and load_complex_type ctx p t = error "Loop found in cascading signatures definitions. Please change order/import" p | TAnon a2 -> PMap.iter (fun f _ -> - if PMap.mem f a2.a_fields then error ("Cannot redefine field " ^ f) p + if PMap.mem f a2.a_fields then error ("Cannot redefine field " ^ f) p; ) a.a_fields; mk_anon (PMap.foldi PMap.add a.a_fields a2.a_fields) | _ -> error "Can only extend classes and structures" p in - let i = load_instance ctx t p false in + let loop t = match follow t with + | TAnon a2 -> + PMap.iter (fun f cf -> + if PMap.mem f a.a_fields then error ("Cannot redefine field " ^ f) p; + a.a_fields <- PMap.add f cf a.a_fields + ) a2.a_fields + | _ -> + error "Multiple structural extension is only allowed for structures" p + in + let il = List.map (fun t -> load_instance ctx t p false) tl in let tr = ref None in let t = TMono tr in let r = exc_protect ctx (fun r -> r := (fun _ -> t); - tr := Some (loop i); + tr := Some (match il with + | [i] -> + mk_extension i + | _ -> + List.iter loop il; + ta); t ) "constraint" in delay ctx PForce (fun () -> ignore(!r()));