forked from HaxeFoundation/haxe
-
Notifications
You must be signed in to change notification settings - Fork 5
/
genobjc.ml
3501 lines (3281 loc) · 128 KB
/
genobjc.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(*
* Haxe/Objective-C Compiler
* Copyright (c)2013 Băluță Cristian
* Based on and including code by (c)2005-2008 Nicolas Cannasse and Hugh Sanderson
*
* This program is free software; you can redistribute it and/or modify
* it under the terms of the GNU General Public License as published by
* the Free Software Foundation; either version 2 of the License, or
* (at your option) any later version.
*
* This program is distributed in the hope that it will be useful,
* but WITHOUT ANY WARRANTY; without even the implied warranty of
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
* GNU General Public License for more details.
*
* You should have received a copy of the GNU General Public License
* along with this program; if not, write to the Free Software
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
open Ast
open Type
open Common
open Unix
open Gencommon
let d = false;;
let joinClassPath path separator =
match fst path, snd path with
| [], s -> s
| el, s -> String.concat separator el ^ separator ^ s
;;
let getFirstMetaValue key meta =
let rec loop = function
| [] -> ""
| (k,[Ast.EConst (Ast.String name),_],_) :: l when k = key -> name
| _ :: l -> loop l
in
loop meta;
;;
let getAllMetaValues key meta =
let values = ref [] in
let rec loop = function
| [] -> ()
| (k,[Ast.EConst (Ast.String name),_],_) :: l when k = key ->
values := name :: !values;
loop l;
| _ :: l -> loop l
in
loop meta;
!values;
;;
let isSubstringOf s1 s2 =
let re = Str.regexp_string s2 in
try ignore (Str.search_forward re s1 0); true
with Not_found -> false
;;
type header_kind =
| HeaderObjc
| HeaderObjcWithoutParams
| HeaderBlock
| HeaderBlockInline
| HeaderDynamic
type call_kind =
| CallObjc
| CallC
| CallBlock
| CalBlockInline
class importsManager =
object(this)
val mutable all_frameworks : string list = []
val mutable class_frameworks : string list = []
val mutable class_imports : path list = []
val mutable class_imports_custom : string list = []
method add_class_path (class_path:path) = match class_path with
| ([],"StdTypes")
| ([],"Int")
| ([],"Float")
| ([],"Dynamic")
| ([],"T")
| ([],"Bool") -> ();
| _ -> if not (List.mem class_path class_imports) then class_imports <- List.append class_imports [class_path];
method add_class (class_def:tclass) =
if (Meta.has Meta.Framework class_def.cl_meta) then begin
let name = getFirstMetaValue Meta.Framework class_def.cl_meta in
this#add_framework name;
end else begin
this#add_class_path class_def.cl_module.m_path;
end
method add_abstract (a_def:tabstract) =
if (Meta.has Meta.Framework a_def.a_meta) then begin
let name = getFirstMetaValue Meta.Framework a_def.a_meta in
this#add_framework name;
end else begin
this#add_class_path a_def.a_module.m_path;
end
method add_framework (name:string) =
if not (List.mem name all_frameworks) then all_frameworks <- List.append all_frameworks [name];
if not (List.mem name class_frameworks) then class_frameworks <- List.append class_frameworks [name];
method add_class_import_custom (class_path:string) = class_imports_custom <- List.append class_imports_custom ["\""^class_path^"\""];
method add_class_include_custom (class_path:string) = class_imports_custom <- List.append class_imports_custom ["<"^class_path^">"];
method remove_class_path (class_path:path) = ()(* List.remove class_imports [class_path] *)(* TODO: *)
method get_all_frameworks = all_frameworks
method get_class_frameworks = class_frameworks
method get_imports = class_imports
method get_imports_custom = class_imports_custom
method reset = class_frameworks <- []; class_imports <- []; class_imports_custom <- []
end;;
class filesManager imports_manager app_name =
object(this)
val app_name = app_name
val mutable prefix = ""
val mutable imports = imports_manager
val mutable all_frameworks : (string * string * string) list = [](* UUID * fileRef * f_name *)
val mutable source_files : (string * string * path * string) list = [](* UUID * fileRef * filepath * ext *)
val mutable source_folders : (string * string * path) list = [](* UUID * fileRef * filepath *)
val mutable resource_files : (string * string * path * string) list = [](* UUID * fileRef * filepath * ext *)
method generate_uuid =
let id = String.make 24 'A' in
let chars = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" in
for i = 0 to 23 do id.[i] <- chars.[Random.int 36] done;
id
method generate_uuid_for_file file_path =
let app_name = app_name^prefix in
let id = String.make 24 'A' in
let md5 = Digest.to_hex (Digest.string (joinClassPath file_path "/")) in
for i = 0 to 23 do
id.[i] <- if String.length app_name > i then app_name.[i] else md5.[i];
done;
String.uppercase id
method register_source_file file_path ext =
prefix <- "SRC" ^ (if String.length ext > 1 then (String.sub ext 1 1) else "");
let uuid = this#generate_uuid_for_file file_path in
prefix <- "SRCREF" ^ (if String.length ext > 1 then (String.sub ext 1 1) else "");
let uuid_ref = this#generate_uuid_for_file file_path in
source_files <- List.append source_files [uuid, uuid_ref, file_path, ext];
method register_source_folder file_path =
prefix <- "SRCDIR";
let uuid = this#generate_uuid_for_file file_path in
prefix <- "SRCDIRREF";
let uuid_ref = this#generate_uuid_for_file file_path in
source_folders <- List.append source_folders [uuid, uuid_ref, file_path];
method register_resource_file file_path ext =
prefix <- "RES";
let uuid = this#generate_uuid_for_file file_path in
prefix <- "RESREF";
let uuid_ref = this#generate_uuid_for_file file_path in
resource_files <- List.append resource_files [uuid, uuid_ref, file_path, ext];
method get_source_files = source_files
method get_source_folders = source_folders
method get_resource_files = resource_files
method get_frameworks =
if List.length all_frameworks = 0 then
List.iter ( fun name ->
let file_path_fmk = (["FMK"], name) in
let file_path_ref = (["FMK";"REF"], name) in
all_frameworks <- List.append all_frameworks [this#generate_uuid_for_file file_path_fmk, this#generate_uuid_for_file file_path_ref, name]
) imports#get_all_frameworks;
all_frameworks
end
;;
class sourceWriter write_func close_func =
object(this)
val indent_str = "\t"
val mutable indent = ""
val mutable indents = []
val mutable just_finished_block = false
val mutable can_indent = true
method close = close_func(); ()
method indent_one = this#write indent_str
method push_indent = indents <- indent_str::indents; indent <- String.concat "" indents
method pop_indent = match indents with
| h::tail -> indents <- tail; indent <- String.concat "" indents
| [] -> indent <- "/*?*/";
method get_indent = indent
method new_line = this#write "\n"; can_indent <- true;
method write str =
write_func (if can_indent then (indent^str) else str);
just_finished_block <- false;
can_indent <- false
method begin_block = this#write (" {"); this#push_indent; this#new_line
method end_block = this#pop_indent; this#write "}"; just_finished_block <- true
method terminate_line = this#write (if just_finished_block then "" else ";"); this#new_line
method write_header_import (module_path:path) (class_path:path) =
let steps = ref "" in
if List.length (fst module_path) > 0 then List.iter (fun (p) -> steps := !steps ^ "../") (fst module_path);
this#write ("#import \"" ^ !steps ^ (joinClassPath class_path "/") ^ ".h\"\n")
method write_headers_imports (module_path:path) class_paths =
List.iter (fun class_path -> this#write_header_import module_path class_path ) class_paths
method write_headers_imports_custom class_paths =
List.iter (fun class_path -> this#write ("#import " ^ class_path ^ "\n")) class_paths
method write_frameworks_imports f_list =
List.iter (fun name ->
this#write ("#import <" ^ name ^ "/" ^ name ^ ".h>\n")
) f_list
method write_copy (module_path:path) (app_name:string) =
this#write ("//
// " ^ (snd module_path) ^ "
// " ^ app_name ^ "
//
// Code generated by Haxe Objective-C target
//
");
this#new_line
end
;;
let rec mkdir base dir_list =
( match dir_list with
| [] -> ()
| dir :: remaining ->
let path = match base with
| "" -> dir
| "/" -> "/" ^ dir
| _ -> base ^ "/" ^ dir in
if (not (path="" || (((String.length path)=2) && ((String.sub path 1 1)=":")))) then
if not (Sys.file_exists path) then Unix.mkdir path 0o755;
mkdir (if (path="") then "/" else path) remaining
)
;;
let cachedSourceWriter filename =
try
let in_file = open_in filename in
let old_contents = Std.input_all in_file in
close_in in_file;
let buffer = Buffer.create 0 in
let add_buf str = Buffer.add_string buffer str in
let close = fun () ->
let contents = Buffer.contents buffer in
if (not (contents=old_contents) ) then begin
let out_file = open_out filename in
output_string out_file contents;
close_out out_file;
end;
in
new sourceWriter (add_buf) (close);
with _ ->
let out_file = open_out filename in
new sourceWriter (output_string out_file) (fun ()-> close_out out_file)
;;
let newSourceFile base_dir class_path extension =
mkdir base_dir ("" :: (fst class_path));
cachedSourceWriter (base_dir ^ "/" ^ ( String.concat "/" (fst class_path) ) ^ "/" ^ (snd class_path) ^ extension)
;;
(* let makeBaseDirectory file = mkdir "" ( ( Str.split_delim (Str.regexp "[\\/]+") file ) );; *)
(* Objective-C code generation context *)
type context = {
com : Common.context;
mutable ctx_file_info : (string,string) PMap.t ref;
mutable writer : sourceWriter;
mutable imports_manager : importsManager;
mutable get_sets : (string * bool,string) Hashtbl.t;
mutable function_arguments : (string,tconstant) Hashtbl.t;
mutable class_def : tclass;
mutable in_value : tvar option;
mutable in_static : bool;
mutable evaluating_condition : bool;
mutable is_protocol : bool;
mutable is_category : bool;(* In categories @synthesize should be replaced with the getter and setter *)
mutable handle_break : bool;
mutable generating_header : bool;
mutable generating_var : bool;
mutable type_of_generated_var : string;
mutable generating_objc_block : bool;
mutable generating_objc_block_asign : bool;
mutable generating_object_declaration : bool;
mutable generating_constructor : bool;
mutable generating_self_access : bool;
mutable generating_property_access : bool;
mutable generating_left_side_of_operator : bool;
mutable generating_right_side_of_operator : bool;
mutable generating_array_insert : bool;
mutable generating_method_argument : bool;
mutable generating_selector : bool;
mutable generating_custom_selector : bool;
mutable generating_c_call : bool;
mutable generating_calls : int;(* How many calls are generated in a row *)
mutable generating_fields : int;(* How many fields are generated in a row *)
mutable generating_string_append : int;
mutable require_pointer : bool;
mutable return_needs_semicolon : bool;
mutable gen_uid : int;
mutable local_types : t list;
}
let newContext common_ctx writer imports_manager file_info = {
com = common_ctx;
ctx_file_info = file_info;
writer = writer;
imports_manager = imports_manager;
get_sets = Hashtbl.create 0;
function_arguments = Hashtbl.create 0;
class_def = null_class;
in_value = None;
in_static = false;
evaluating_condition = false;
is_protocol = false;
is_category = false;
handle_break = false;
generating_header = false;
generating_var = false;
type_of_generated_var = "";
generating_objc_block = false;
generating_objc_block_asign = false;
generating_object_declaration = false;
generating_constructor = false;
generating_self_access = false;
generating_property_access = false;
generating_left_side_of_operator = false;
generating_right_side_of_operator = false;
generating_array_insert = false;
generating_method_argument = false;
generating_selector = false;
generating_custom_selector = false;
generating_c_call = false;
generating_calls = 0;
generating_fields = 0;
generating_string_append = 0;
require_pointer = false;
return_needs_semicolon = false;
gen_uid = 0;
local_types = [];
}
type module_context = {
mutable module_path_m : path;
mutable module_path_h : path;
mutable ctx_m : context;
mutable ctx_h : context;
}
let newModuleContext ctx_m ctx_h = {
module_path_m = ([],"");
module_path_h = ([],"");
ctx_m = ctx_m;
ctx_h = ctx_h;
}
let debug ctx str =
if d then ctx.writer#write str
;;
let isVarField e v =
match e.eexpr, follow e.etype with
| TTypeExpr (TClassDecl c),_
| _,TInst(c,_) ->
(try
let f = try PMap.find v c.cl_fields with Not_found -> PMap.find v c.cl_statics in
(match f.cf_kind with Var _ -> true | _ -> false)
with Not_found -> false)
| _ -> false
;;
let isSpecialCompare e1 e2 =
match e1.eexpr, e2.eexpr with
| TConst TNull, _ | _ , TConst TNull -> None
| _ ->
match follow e1.etype, follow e2.etype with
| TInst ({ cl_path = [],"Xml" } as c,_) , _ | _ , TInst ({ cl_path = [],"Xml" } as c,_) -> Some c
| _ -> None
;;
let rec isString ctx e =
(* TODO: left side of the binop is never discovered as being string *)
(* ctx.writer#write ("\"-CHECK ISSTRING-\""); *)
(match e.eexpr with
| TBinop (op,e1,e2) -> (* ctx.writer#write ("\"-redirect check isString-\""); *) isString ctx e1 || isString ctx e2
| TLocal v ->
(* ctx.writer#write ("\"-check local-\""); *)
(match v.v_type with
(* match e.etype with *)
| TMono r ->
(match !r with
| None -> false
| Some t ->
(match t with
| TInst (c,tl) ->
(match c.cl_path with
| ([], "String") -> true
| _ -> false)
| _ -> false
)
)
(* | TConst c -> true *)
| _ -> false
)
| TConst (TString s) -> true
| TField (e,fa) ->
(* e might be of type TThis and we need to check the fa *)
let b1 = isString ctx e in
if b1 = false then begin
(* If the expression is not string check the fa also *)
(match fa with
| FInstance (tc,_,tcf)
| FStatic (tc,tcf) ->
let ft = field_type tcf in
(match ft with
| TMono r ->
(match !r with
| None -> false
| Some t ->
(match t with
| TInst (c,tl) ->
(match c.cl_path with
| ([], "String") -> true
| _ -> false)
| _ -> false
)
)
| TEnum _ -> (* ctx.writer#write "CASTTenum"; *)false;
| TInst (tc, tp) -> (* ctx.writer#write (snd tc.cl_path);false; *)
if (snd tc.cl_path) = "String" then true
else false
| TType _ -> ctx.writer#write "CASTTType";false;
| TFun (_,t) -> (* ctx.writer#write "CASTTFun"; *)
(* ctx.writer#write ("TFun"^(snd tc.cl_path)); *)
(* Analize the return type of the function *)
(match t with
| TMono r ->
(match !r with
| None -> false
| Some t ->
(match t with
| TInst (c,tl) ->
(match c.cl_path with
| ([], "String") -> true
| _ -> false)
| _ -> false
)
)
| TEnum _ -> (* ctx.writer#write "CASTTenum"; *)false;
| TInst (tc, tp) -> (* ctx.writer#write (snd tc.cl_path); *)
if (snd tc.cl_path) = "String" then true else false
| TType _ -> ctx.writer#write "CASTTType";false;
| TFun (_,t) -> ctx.writer#write "CASTTFun";
(* ctx.writer#write ("TFun"^(snd tc.cl_path)); *)
false;
| TAnon _ -> ctx.writer#write "CASTTAnon";false;
| TDynamic _ -> ctx.writer#write "isstringCASTTDynamic";false;
| TLazy _ -> ctx.writer#write "CASTTLazy";false;
| TAbstract (ta,tp) -> (* ctx.writer#write "CASTTAbstract"; *)
if (snd ta.a_path) = "String" then true
else false
)
| TAnon _ -> ctx.writer#write "CASTTAnon";false;
| TDynamic _ -> ctx.writer#write "isstringCASTTDynamic";false;
| TLazy _ -> ctx.writer#write "CASTTLazy";false;
| TAbstract (ta,tp) -> (* ctx.writer#write "CASTTAbstract"; *)
if (snd ta.a_path) = "String" then true
else false
)
(* | FStatic _ -> ctx.writer#write "isstrFStatic";false; *)
| FAnon tcf -> (* ctx.writer#write "isstrFAnon-"; *)
(match tcf.cf_type with
| TMono r -> ctx.writer#write "Mono";false;
| TEnum _ -> ctx.writer#write "Tenum";false;
| TInst (tc, tp) -> (* ctx.writer#write (snd tc.cl_path); *)
if (snd tc.cl_path) = "String" then true else false
| TType _ -> ctx.writer#write "Type";false;
| TFun (_,t) -> ctx.writer#write "TFun";
(* ctx.writer#write ("TFun"^(snd tc.cl_path)); *)
false;
| TAnon _ -> ctx.writer#write "TAnon";false;
| TDynamic _ -> ctx.writer#write "isstringCASTTDynamic";false;
| TLazy _ -> ctx.writer#write "TLazy";false;
| TAbstract (ta,tp) -> (* ctx.writer#write "CASTTAbstract"; *)
if (snd ta.a_path) = "String" then true
else false
)
| FDynamic _ -> (* ctx.writer#write "isstrFDynamic"; *)false;
| FClosure _ -> ctx.writer#write "isstrFClosure";false;
| FEnum _ -> (* ctx.writer#write "isstrFEnum"; *)false;
);
end else b1
| TCall (e,el) -> isString ctx e
| TConst c ->
(* ctx.writer#write ("\"-check const-\""); *)
(match c with
| TString s -> true;
| TInt i -> false;
| TFloat f -> false;
| TBool b -> false;
| TNull -> false;
| TThis -> false;(* In this case the field_access will be checked for String as well *)
| TSuper -> false;
)
| _ -> false)
;;
let rec isArray e =
(match e.eexpr with
| TArray (e1,e2) -> true
| _ -> false)
;;
(* 'id' is a pointer but does not need to specify it *)
let isPointer t =
match t with
| "void" | "id" | "BOOL" | "int" | "uint" | "NSInteger" | "NSUInteger" | "float" | "CGFloat" | "CGRect" | "CGPoint" | "CGSize" | "SEL" | "CGImageRef" -> false
| _ -> true
(* TODO: enum is not pointer *)
;;
let addPointerIfNeeded t =
if (isPointer t) then "*" else ""
;;
(* Generating correct type *)
let remapHaxeTypeToObjc ctx is_static path pos =
match path with
| ([],name) ->
(match name with
| "Int" -> "NSInteger"
| "Float" -> "CGFloat"
| "Dynamic" -> "id"
| "Bool" -> "BOOL"
| "String" -> "NSString"
| "Date" -> "NSDate"
| "Array" -> "NSMutableArray<id>"
| "Void" -> "void"
| _ -> name)
| (pack,name) ->
(match name with
| "T" -> "id"
| _ -> name)
;;
(* Convert function names that can't be written in c++ ... *)
let remapKeyword name =
match name with
| "int" | "float" | "double" | "long" | "short" | "char" | "void"
| "self" | "super" | "id" | "____init" | "bycopy" | "inout" | "oneway" | "byref"
| "SEL" | "IMP" | "Protocol" | "BOOL" | "YES" | "NO"
| "in" | "out" | "auto" | "const" | "delete"
| "enum" | "extern" | "friend" | "goto" | "operator" | "protected" | "register"
| "sizeof" | "template" | "typedef" | "union"
| "volatile" | "or" | "and" | "xor" | "or_eq" | "not"
| "and_eq" | "xor_eq" | "typeof" | "stdin" | "stdout" | "stderr"
| "BIG_ENDIAN" | "LITTLE_ENDIAN" | "assert" | "NULL" | "nil" | "wchar_t" | "EOF"
| "const_cast" | "dynamic_cast" | "explicit" | "export" | "mutable" | "namespace"
| "reinterpret_cast" | "static_cast" | "typeid" | "typename" | "virtual"
| "initWithFrame" | "initWithStyle"
| "signed" | "unsigned" | "struct" -> "_" ^ name
| "asm" -> "_asm_"
| "__null" -> "null"
| "__class" -> "class"
| x -> x
let appName ctx =
(* The name of the main class is the name of the app. *)
match ctx.main_class with
| Some path -> (snd path)
| _ -> "HaxeCocoaApp"
;;
let srcDir ctx = (ctx.file ^ "/" ^ (appName ctx))
let rec createDirectory acc = function
| [] -> ()
| d :: l ->
let dir = String.concat "/" (List.rev (d :: acc)) in
if not (Sys.file_exists dir) then Unix.mkdir dir 0o755;
createDirectory (d :: acc) l
;;
let saveLocals ctx = (fun() -> ())
let genLocal ctx l =
ctx.gen_uid <- ctx.gen_uid + 1;
if ctx.gen_uid = 1 then l else l ^ string_of_int ctx.gen_uid
;;
let unsupported p = error "This expression cannot be generated to Objective-C" p
let rec concat ctx s f = function
| [] -> ()
| [x] -> f x
| x :: l ->
f x;
ctx.writer#write s;
concat ctx s f l
;;
let parent e =
match e.eexpr with
| TParenthesis _ -> e
| _ -> mk (TParenthesis e) e.etype e.epos
;;
let rec typeToString ctx t p =
match t with
(* | TEnum (te,tp) -> "TEnumInBlock" *)
| TEnum _ | TInst _ when List.memq t ctx.local_types ->
"id"
| TAbstract (a,_) ->(* ctx.writer#write "TAbstract?"; *)
ctx.imports_manager#add_abstract a;
remapHaxeTypeToObjc ctx true a.a_path p;
| TEnum (e,_) ->(* ctx.writer#write "TEnum-"; *)
if e.e_extern then
(match e.e_path with
| [], "Void" -> "void"
| [], "Bool" -> "BOOL"
| _, name -> name
)
else begin
(* Import the module but use the type itself *)
ctx.imports_manager#add_class_path e.e_module.m_path;
remapHaxeTypeToObjc ctx true e.e_path p
end
| TInst (c,_) ->(* ctx.writer#write "TInst?"; *)
(match c.cl_kind with
| KNormal | KGeneric | KGenericInstance _ ->
ctx.imports_manager#add_class c;
remapHaxeTypeToObjc ctx false c.cl_path p
| KTypeParameter _ | KExtension _ | KExpr _ | KMacroType | KAbstractImpl _ | KGenericBuild _ -> "id")
| TFun (args, ret) ->
let r = ref "" in
let index = ref 0 in
List.iter ( fun (name, b, t) ->
(* print_endline name; *)
(* ctx.generating_method_argument <- true; *)
(* if Array.length sel_arr > 0 then
r := !r ^ (" "^sel_arr.(!index)^":")
else *)
r := !r ^ name;(* (if !index = 0 then ":" else (" "^(remapKeyword name)^":")); *)
(* generateValue ctx args_array_e.(!index); *)
index := !index + 1;
) args;
(* Write the type of a function, the block definition *)
(* !r *)
"id"
| TMono r -> (match !r with None -> "id" | Some t -> typeToString ctx t p)
| TAnon anon -> "id"
| TDynamic _ -> "id"
| TType (t,args) ->
(* ctx.writer#write "?TType?"; *)
(match t.t_path with
| [], "UInt" -> "NSUInteger"
| [] , "Null" ->
(match args with
| [t] ->
(* Saw it generated in the function optional arguments *)
(match follow t with
| TAbstract ({ a_path = [],"UInt" },_) -> "NSUInteger"
| TAbstract ({ a_path = [],"Int" },_) -> "NSInteger"
| TAbstract ({ a_path = [],"Float" },_) -> "CGFloat"
| TAbstract ({ a_path = [],"Bool" },_) -> "BOOL"
| TInst ({ cl_path = [],"Int" },_) -> "NSInteger"
| TInst ({ cl_path = [],"Float" },_) -> "CGFloat"
| TEnum ({ e_path = [],"Bool" },_) -> "BOOL"
| _ -> typeToString ctx t p)
| _ -> assert false);
| _ -> typeToString ctx (apply_params t.t_params args t.t_type) p)
| TLazy f ->
typeToString ctx ((!f)()) p
;;
let rec iterSwitchBreak in_switch e =
match e.eexpr with
| TFunction _ | TWhile _ | TFor _ -> ()
| TSwitch _ (*| TPatMatch _ *) when not in_switch -> iterSwitchBreak true e
| TBreak when in_switch -> raise Exit
| _ -> iter (iterSwitchBreak in_switch) e
;;
let handleBreak ctx e =
let old_handle = ctx.handle_break in
try
iterSwitchBreak false e;
ctx.handle_break <- false;
(fun() -> ctx.handle_break <- old_handle)
with
Exit ->
ctx.writer#write "try {";
ctx.writer#new_line;
ctx.handle_break <- true;
(fun() ->
ctx.writer#begin_block;
ctx.handle_break <- old_handle;
ctx.writer#new_line;
ctx.writer#write "} catch( e : * ) { if( e != \"__break__\" ) throw e; }";
)
;;
let this ctx = "self"(* if ctx.in_value <> None then "__self" else "self" *)
;;
(* TODO: Generate resources that Objective-C can understand *)
(* Put strings in a .plist file
Put images in the Resources directory *)
let generateResources common_ctx =
if Hashtbl.length common_ctx.resources <> 0 then begin
let dir = (common_ctx.file :: ["Resources"]) in
createDirectory [] dir;
let resource_file = newSourceFile common_ctx.file ([],"Resources") ".plist" in
resource_file#write "#include <xxx.h>\n\n";
(* let add_resource name data =
let ch = open_out_bin (String.concat "/" (dir @ [name])) in
output_string ch data;
close_out ch
in
Hashtbl.iter (fun name data -> add_resource name data) infos.com.resources;
let ctx = init infos ([],"__resources__") in
ctx.writer#write "\timport flash.utils.Dictionary;\n";
ctx.writer#write "\tpublic class __resources__ {\n";
ctx.writer#write "\t\tpublic static var list:Dictionary;\n";
let inits = ref [] in
let k = ref 0 in
Hashtbl.iter (fun name _ ->
let varname = ("v" ^ (string_of_int !k)) in
k := !k + 1;
ctx.writer#write (Printf.sprintf "\t\t[Embed(source = \"__res/%s\", mimeType = \"application/octet-stream\")]\n" name;
ctx.writer#write (Printf.sprintf "\t\tpublic static var %s:Class;\n" varname;
inits := ("list[\"" ^name^ "\"] = " ^ varname ^ ";") :: !inits;
) infos.com.resources;
ctx.writer#write "\t\tstatic public function __init__():void {\n";
ctx.writer#write "\t\t\tlist = new Dictionary();\n";
List.iter (fun init ->
ctx.writer#write (Printf.sprintf "\t\t\t%s\n" init
) !inits;
ctx.writer#write "\t\t}\n";
ctx.writer#write "\t}\n";
ctx.writer#write "}"; *)
(* close ctx; *)
end
;;
let generateConstant ctx p = function
| TInt i ->
(* if ctx.generating_string_append > 0 then
ctx.writer#write (Printf.sprintf "@\"%ld\"" i)
else *) if ctx.require_pointer then
ctx.writer#write (Printf.sprintf "@(%ld)" i) (* %ld = int32 = (Int32.to_string i) *)
else
ctx.writer#write (Printf.sprintf "%ld" i)
| TFloat f ->
(* if ctx.generating_string_append > 0 then
ctx.writer#write (Printf.sprintf "@\"%s\"" f)
else *) if ctx.require_pointer then
ctx.writer#write (Printf.sprintf "@(%s)" f)
else
ctx.writer#write f
| TString s -> ctx.writer#write (Printf.sprintf "@\"%s\"" (Ast.s_escape s))
| TBool b -> ctx.writer#write (if b then "YES" else "NO")
| TNull -> ctx.writer#write (if ctx.require_pointer then "[NSNull null]" else "nil")
| TThis ->
ctx.writer#write (if ctx.require_pointer then "@(self" else "self");
ctx.generating_self_access <- true
| TSuper -> ctx.writer#write "super"
;;
let defaultValue s =
match s with
| "Bool" | "BOOL" -> "NO"
| _ -> "nil"
;;
(* A function header in objc is a message *)
(* We need to follow some strict rules *)
let generateFunctionHeader ctx name (meta:metadata) (f:tfunc) params pos is_static kind =
(* ctx.writer#write ("gen-func-"); *)
let old = ctx.in_value in
let locals = saveLocals ctx in
let old_t = ctx.local_types in
ctx.in_value <- None;
ctx.local_types <- List.map snd params @ ctx.local_types;
let sel = if Meta.has Meta.Selector meta then (getFirstMetaValue Meta.Selector meta) else "" in
let first_arg = ref true in
let sel_list = if (String.length sel > 0) then Str.split_delim (Str.regexp ":") sel else [] in
let sel_arr = Array.of_list sel_list in
let return_type = if ctx.generating_constructor then "id" else typeToString ctx f.tf_type pos in
(* This part generates the name of the function, the first part of the objc message *)
let func_name = if Array.length sel_arr > 1 then sel_arr.(0) else begin
(match name with None -> "" | Some (n,meta) ->
let rec loop = function
| [] -> (* processFunctionName *) n
| _ :: l -> loop l
in
"" ^ loop meta
)
end in
(* Return type and function name *)
(match kind with
| HeaderObjc | HeaderObjcWithoutParams ->
let method_kind = if is_static then "+" else "-" in
ctx.writer#write (Printf.sprintf "%s (%s%s)" method_kind return_type (addPointerIfNeeded return_type));
ctx.writer#write (Printf.sprintf "%s" (remapKeyword func_name));
| HeaderBlock ->
(* [^BOOL() { return p < [a count]; } copy] *)
ctx.writer#write (Printf.sprintf "%s%s" return_type (addPointerIfNeeded return_type))
| HeaderBlockInline ->
ctx.writer#write "^"
| HeaderDynamic ->
(* void(^block3)(NSString); *)
ctx.writer#write (Printf.sprintf "%s%s(^hx_dyn_%s)" return_type (addPointerIfNeeded return_type) func_name);
);
(* Function arguments and types *)
Hashtbl.clear ctx.function_arguments;
(* Generate the arguments of the function. Ignore the message name of the first arg *)
(* TODO: add (void) if no argument is present. Not mandatory *)
(match kind with
| HeaderObjc ->
let index = ref 0 in
concat ctx " " (fun (v,c) ->
let type_name = typeToString ctx v.v_type pos in
let arg_name = (remapKeyword v.v_name) in
let message_name = if !first_arg then "" else if Array.length sel_arr > 1 then sel_arr.(!index) else arg_name in
ctx.writer#write (Printf.sprintf "%s:(%s%s)%s" (remapKeyword message_name) type_name (addPointerIfNeeded type_name) arg_name);
first_arg := false;
index := !index+1;
if not ctx.generating_header then begin
match c with
| None -> ();(* Hashtbl.add ctx.function_arguments arg_name (defaultValue arg_name) *)
| Some c -> Hashtbl.add ctx.function_arguments arg_name c
end
) f.tf_args;
| HeaderObjcWithoutParams ->
concat ctx " " (fun (v,c) ->
let type_name = typeToString ctx v.v_type pos in
let arg_name = (remapKeyword v.v_name) in
ctx.writer#write (Printf.sprintf ":(%s%s)%s" type_name (addPointerIfNeeded type_name) arg_name);
if not ctx.generating_header then begin
match c with
| None -> ();(* Hashtbl.add ctx.function_arguments arg_name (defaultValue arg_name) *)
| Some c -> Hashtbl.add ctx.function_arguments arg_name c
end
) f.tf_args;
| HeaderBlock ->
ctx.writer#write "(";
concat ctx ", " (fun (v,c) ->
let type_name = typeToString ctx v.v_type pos in
ctx.writer#write (Printf.sprintf "%s%s" type_name (addPointerIfNeeded type_name));
) f.tf_args;
ctx.writer#write ")";
| HeaderBlockInline ->
(* Inlined blocks require pointers? *)
ctx.writer#write "(";
concat ctx ", " (fun (v,c) ->
let type_name = typeToString ctx v.v_type pos in
let arg_name = (remapKeyword v.v_name) in
let is_enum = (match v.v_type with | TEnum _ -> true | _ -> false) in
ctx.writer#write (Printf.sprintf "%s %s%s" type_name (if is_enum then "" else (addPointerIfNeeded type_name)) arg_name);
(* if not ctx.generating_header then begin
match c with
| None -> ();(* Hashtbl.add ctx.function_arguments arg_name (defaultValue arg_name) *)
| Some c -> Hashtbl.add ctx.function_arguments arg_name c
end *)
) f.tf_args;
ctx.writer#write ")";
| HeaderDynamic ->
(* Arguments types *)
ctx.writer#write "(";
concat ctx ", " (fun (v,c) ->
let type_name = typeToString ctx v.v_type pos in
(* let arg_name = (remapKeyword v.v_name) in *)
ctx.writer#write (Printf.sprintf "%s%s" type_name (addPointerIfNeeded type_name));
) f.tf_args;
ctx.writer#write ")";
);
(* Generate the block version of the method. When we pass a reference to a function we pass to this block *)
(* if not ctx.generating_header then begin
(* void(^block_block2)(int i) = ^(int i){ [me login]; }; *)
ctx.writer#write (Printf.sprintf "%s%s(^block_%s)" return_type (addPointerIfNeeded return_type) func_name);
let gen_block_args = fun() -> (
ctx.writer#write "(";
concat ctx ", " (fun (v,c) ->
let type_name = typeToString ctx v.v_type p in
ctx.writer#write (Printf.sprintf "%s %s%s" type_name (addPointerIfNeeded type_name) (remapKeyword v.v_name));
) f.tf_args;
ctx.writer#write ")";
) in
gen_block_args();
ctx.writer#write " = ^";
gen_block_args();
ctx.writer#write (Printf.sprintf " { %s[%s " (if return_type="void" then "" else "return ") (if is_static then "me" else "me"));
ctx.writer#write func_name;
let first_arg = ref true in
concat ctx " " (fun (v,c) ->
let type_name = typeToString ctx v.v_type p in
let message_name = if !first_arg then "" else (remapKeyword v.v_name) in
ctx.writer#write (Printf.sprintf "%s:%s" message_name (remapKeyword v.v_name));
first_arg := false;
) f.tf_args;
ctx.writer#write "]; };\n"
end; *)
(fun () ->
ctx.in_value <- old;
locals();
ctx.local_types <- old_t;
)
;;
(* arg_list is of type Type.texpr list *)
let rec generateCall ctx (func:texpr) arg_list =
debug ctx ("\"-CALL-"^(Type.s_expr_kind func)^">\"");
(* Generate a C call. Used in some low level operations from cocoa frameworks: CoreGraphics *)
if ctx.generating_c_call then begin
debug ctx "-C-";
match func.eexpr, arg_list with
| TCall (x,_) , el ->
ctx.writer#write "(";
generateValue ctx func;
ctx.writer#write ")";
ctx.writer#write "(";
concat ctx ", " (generateValue ctx) arg_list;
ctx.writer#write ")";
(* | TField(ee,v),args when isVarField ee v ->
ctx.writer#write "TField(";
generateValue ctx func;
ctx.writer#write ")";
ctx.writer#write "(";
concat ctx ", " (generateValue ctx) arg_list;
ctx.writer#write ")" *)
| _ ->
generateValue ctx func;
ctx.writer#write "(";
concat ctx ", " (generateValue ctx) arg_list;
ctx.writer#write ")";
(* Generate an Objective-C call with [] *)
end else begin
(* ctx.writer#write "-OBJC-"; *)
(* A call should cancel the TField *)
(* When we have a self followed by 2 TFields in a row we use dot notation for the first field *)
if ctx.generating_fields > 0 then ctx.generating_fields <- ctx.generating_fields - 1;
ctx.generating_calls <- ctx.generating_calls + 1;
(* Cast the result *)
(* ctx.writer#write "returning-"; *)
(* (match func.etype with
| TMono _ -> ctx.writer#write "TMono";
| TEnum _ -> ctx.writer#write "Tenum";
| TInst _ -> ctx.writer#write "TInst";
| TType _ -> ctx.writer#write "TType";
| TFun _ -> ctx.writer#write "TFun";
| TAnon _ -> ctx.writer#write "TAnon";
| TDynamic _ -> ctx.writer#write "TDynamic";
| TLazy _ -> ctx.writer#write "TLazy";
| TAbstract _ -> ctx.writer#write "TAbstract";
); *)
ctx.writer#write "[";
(* Check if the called function has a custom selector defined *)
let sel = (match func.eexpr with
(* TODO: TStatic *)
| TField (e, FInstance (c, tp, cf)) ->
if Meta.has Meta.Selector cf.cf_meta then (getFirstMetaValue Meta.Selector cf.cf_meta)
else ""
| _ -> "";
) in
ctx.generating_custom_selector <- (String.length sel > 0);
generateValue ctx func;
ctx.generating_calls <- ctx.generating_calls - 1;
ctx.generating_custom_selector <- false;
if List.length arg_list > 0 then begin
let sel_list = if (String.length sel > 0) then Str.split_delim (Str.regexp ":") sel else [] in
let sel_arr = Array.of_list sel_list in
let args_array_e = Array.of_list arg_list in
let index = ref 0 in
let rec gen et =
(match et with
| TFun (args, ret) ->(* ctx.writer#write "|"; *)
(* let args_array_e = Array.of_list args in *)
if !index < (List.length args) then