From ca998c06deda3d87da333aefdec0ca3bc90f41bd Mon Sep 17 00:00:00 2001 From: "Boris D." Date: Fri, 11 Oct 2024 17:20:40 -0700 Subject: [PATCH] Generate protocol bindings. --- generate/main.ml | 6 ++++++ lib/enc_parser.mly | 16 +++++++++++++--- lib/encode.ml | 10 +++++++--- lib/lib.ml | 27 +++++++++++++++++++++++++-- lib/objc_type.ml | 1 + test/test-parse-enc/test_parse_enc.ml | 9 ++++++++- 6 files changed, 60 insertions(+), 9 deletions(-) diff --git a/generate/main.ml b/generate/main.ml index 17cea35..e27e1e1 100644 --- a/generate/main.ml +++ b/generate/main.ml @@ -8,6 +8,7 @@ Usage: generate-ml -classes | -methods let fw_name = ref "" let gen_classes = ref "" let gen_methods = ref "" +let gen_protocols = ref false let include_superclass = ref false let load_fw = ref "" let open_modules = ref "" @@ -15,6 +16,8 @@ let open_modules = ref "" let speclist = [ ("-classes", Arg.Set_string gen_classes, "Generate classes in ") ; ("-methods", Arg.Set_string gen_methods, "Generate methods in ") + ; ("-protocols", Arg.Set gen_protocols, + "Generate protocols registered in the runtime") ; ("-super", Arg.Set include_superclass, "Include superclass methods in generated module") ; ("-fw", Arg.Set_string fw_name, "Framework name ") @@ -27,6 +30,7 @@ let () = Arg.parse speclist ignore usage; let lib = !gen_classes and cls = !gen_methods + and proto = !gen_protocols and fw = !fw_name and include_superclass = !include_superclass and open_modules = Util.open_modules !open_modules @@ -41,5 +45,7 @@ let () = emit_class_module cls ~fw ~include_superclass ~open_modules) else if not (String.equal cls "") then emit_class_module cls ~fw ~include_superclass ~open_modules + else if proto then + emit_protocols ~open_modules else print_endline usage diff --git a/lib/enc_parser.mly b/lib/enc_parser.mly index aa9ff11..bf9d905 100644 --- a/lib/enc_parser.mly +++ b/lib/enc_parser.mly @@ -7,12 +7,15 @@ %token ID CLASS SEL VOID STRING POINTER BLOCK %token BOOL UCHAR INT UINT SHORT USHORT LONG ULONG LLONG ULLONG %token FLOAT DOUBLE LDOUBLE -%token L_BRACE R_BRACE L_BRACKET R_BRACKET L_PAREN R_PAREN (* EQUAL *) +%token L_BRACE R_BRACE L_BRACKET R_BRACKET L_PAREN R_PAREN %token UNKNOWN EOF BITFIELD -%start prog +// %token EQUAL + +%start nonmeth +%start meth %% -prog: +nonmeth: | x = typ { Some x } | EOF { None }; @@ -51,3 +54,10 @@ struct_fields: tag: TAG { $1 }; field: FIELD { $1 }; + +meth: + | x = meth_sig { Some x } + | EOF { None }; + +meth_sig: x = meth_arg; xs = meth_arg+; EOF { `Method (xs, x) }; +meth_arg: x = typ; NUM { x }; diff --git a/lib/encode.ml b/lib/encode.ml index 923994f..1ccab93 100644 --- a/lib/encode.ml +++ b/lib/encode.ml @@ -13,9 +13,10 @@ let print_position outx lexbuf = pos.pos_lnum (pos.pos_cnum - pos.pos_bol + 1) -let parse_type str = - let lexbuf = Lexing.from_string str in - try Enc_parser.prog Enc_lexer.token lexbuf with +let parse_type ?(is_method = false) str = + let lexbuf = Lexing.from_string str + and f = if is_method then Enc_parser.meth else Enc_parser.nonmeth in + try f Enc_lexer.token lexbuf with | SyntaxError msg -> Printf.eprintf "Lexing SyntaxError: %s\n" msg; Printf.eprintf "%a: syntax error\n%s\n" print_position lexbuf str; @@ -80,6 +81,9 @@ let rec string_of_objc_type ?(raise_on_struct = false) ty = match ty with Option.get tag_opt |> tag_name_to_type else raise (Encode_type "Missing tag") +| `Method (args, ret) -> + (List.map string_of_objc_type args |> String.concat " @-> ") ^ + " @-> returning (" ^ string_of_objc_type ret ^ ")" ;; let type64_to_ctype_string ty_str = diff --git a/lib/lib.ml b/lib/lib.ml index 0930ed5..d8dc142 100644 --- a/lib/lib.ml +++ b/lib/lib.ml @@ -221,7 +221,7 @@ let emit_class_module Printf.fprintf file "%s\n\n" (emit_doc_comment fw cls); Printf.fprintf file "let self = get_class \"%s\"\n\n" cls; - if include_superclass && not (is_null super) then begin + if include_superclass && not (is_nil super) then begin let superclass = Class.get_name super in if ( String.starts_with ~prefix:"NS" superclass && @@ -233,4 +233,27 @@ let emit_class_module emit_metaclass_module ~open_modules ~fw cls cls'; emit_method_bindings ~file bindings; close_out file -;; \ No newline at end of file +;; + +let emit_protocols ~open_modules = + Inspect.registered_protocols () + |> List.iter @@ fun p -> + let pname = Protocol.get_name p in + if not (String.begins_with_char '_' pname) then begin + match Inspect.protocol_methods p with + | [] -> () + | methods -> + let file = open_out (pname ^ ".ml") in + emit_prelude ~open_modules file; + methods + |> List.iter (fun m -> + let cmd = Objc.Method_description.name m in + let name = cmd |> String.split_on_char ':' |> String.concat "'" + and enc = Objc.Method_description.types m in + Encode.parse_type ~is_method:true enc + |> Option.iter (fun typ -> + Printf.fprintf file + "let %s imp = Define.method_spec ~cmd:(selector \"%s\") ~typ:(%s) ~enc:\"%s\" ~imp\n" + (valid_name name) cmd (Encode.string_of_objc_type typ) enc)); + close_out file + end \ No newline at end of file diff --git a/lib/objc_type.ml b/lib/objc_type.ml index 8ca1dbe..77d187c 100644 --- a/lib/objc_type.ml +++ b/lib/objc_type.ml @@ -26,4 +26,5 @@ type t = | `Struct of string option * (string option * t) list | `Union of string option * (string option * t) list | `Array of int * t + | `Method of t list * t ] \ No newline at end of file diff --git a/test/test-parse-enc/test_parse_enc.ml b/test/test-parse-enc/test_parse_enc.ml index cff0642..2c54977 100644 --- a/test/test-parse-enc/test_parse_enc.ml +++ b/test/test-parse-enc/test_parse_enc.ml @@ -141,6 +141,12 @@ let test_parse_vImage_Buffer () = A.check A.bool "Result is Option.some" true (Option.is_some actual); A.check objc_type "same type" expected (Option.get actual) +let test_parse_method_sig () = + let expected = `Method ([`Id; `Sel; `Id; `Llong], `Id) + and actual = Encode.parse_type ~is_method:true "@32@0:8@16q24" in + A.check A.bool "Result is Option.some" true (Option.is_some actual); + A.check objc_type "same type" expected (Option.get actual) + let suite = [ "parse int", `Quick, test_parse_int ; "parse ptr float", `Quick, test_parse_ptr_float @@ -158,7 +164,8 @@ let suite = ; "parse VectorField", `Quick, test_parse_VectorField ; "parse array_of_struct", `Quick, test_parse_array_of_struct ; "parse protocol", `Quick, test_parse_protocol - ; "parse protocol", `Quick, test_parse_vImage_Buffer + ; "parse vImage_Buffer", `Quick, test_parse_vImage_Buffer + ; "parse method sig", `Quick, test_parse_method_sig ] let () = A.run "Enc parser tests" [ "Encode", suite ]