Generate protocol bindings.

generate/main.ml

@@ -8,13 +8,16 @@ Usage: generate-ml -classes <lib-name> | -methods <class-name>
 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 ""
 
 let speclist =
   [ ("-classes", Arg.Set_string gen_classes, "Generate classes in <lib>")
   ; ("-methods", Arg.Set_string gen_methods, "Generate methods in <class>")
+  ; ("-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 <fw-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

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 <Objc_type.t option> prog
+// %token EQUAL
+
+%start <Objc_type.t option> nonmeth
+%start <Objc_type.t option> 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 };

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 =

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
-;;
+;;
+
+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

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
   ]

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 ]