Expect-style tests for parser

src/compilerlib/dune

@@ -14,5 +14,5 @@
    pb_parsing pb_parsing_lexer pb_parsing_parser pb_parsing_parse_tree
    pb_parsing_util pb_typing_graph pb_typing pb_typing_recursion
    pb_typing_resolution pb_typing_type_tree pb_typing_util
-   pb_typing_validation pb_util)
+   pb_typing_validation pb_util pb_format_util)
  (libraries stdlib-shims))

src/compilerlib/pb_field_type.ml

@@ -111,3 +111,70 @@ let parse = function
   | "string" -> `String
   | "bytes" -> `Bytes
   | s -> `User_defined (unresolved_of_string s)
+
+open Format
+
+let rec pp_type_path ppf path =
+  match path with
+  | [] -> fprintf ppf "(empty)"
+  | [ name ] -> fprintf ppf "%S" name
+  | name :: rest ->
+    fprintf ppf "%S." name;
+    pp_type_path ppf rest
+
+let pp_builtin_type_floating_point ppf t =
+  match t with
+  | `Double -> fprintf ppf "Double"
+  | `Float -> fprintf ppf "Float"
+
+let pp_builtin_type_unsigned_int ppf t =
+  match t with
+  | `Uint32 -> fprintf ppf "Uint32"
+  | `Uint64 -> fprintf ppf "Uint64"
+
+let pp_builtin_type_signed_int ppf t =
+  match t with
+  | `Int32 -> fprintf ppf "Int32"
+  | `Int64 -> fprintf ppf "Int64"
+  | `Sint32 -> fprintf ppf "Sint32"
+  | `Sint64 -> fprintf ppf "Sint64"
+  | `Fixed32 -> fprintf ppf "Fixed32"
+  | `Fixed64 -> fprintf ppf "Fixed64"
+  | `Sfixed32 -> fprintf ppf "Sfixed32"
+  | `Sfixed64 -> fprintf ppf "Sfixed64"
+
+let pp_builtin_type_int ppf t =
+  match t with
+  | #builtin_type_unsigned_int as unsigned_int ->
+    pp_builtin_type_unsigned_int ppf unsigned_int
+  | #builtin_type_signed_int as signed_int ->
+    pp_builtin_type_signed_int ppf signed_int
+
+let pp_map_key_type ppf t =
+  match t with
+  | #builtin_type_int as int_type -> pp_builtin_type_int ppf int_type
+  | `Bool -> fprintf ppf "Bool"
+  | `String -> fprintf ppf "String"
+
+let pp_builtin_type ppf t =
+  match t with
+  | #builtin_type_floating_point as float_type ->
+    pp_builtin_type_floating_point ppf float_type
+  | #builtin_type_int as int_type -> pp_builtin_type_int ppf int_type
+  | `Bool -> fprintf ppf "Bool"
+  | `String -> fprintf ppf "String"
+  | `Bytes -> fprintf ppf "Bytes"
+
+let pp_unresolved ppf unresolved =
+  fprintf ppf "{@[<v 2>@,type_path: %a;@,type_name: %S;@,from_root: %b@,@]}"
+    pp_type_path unresolved.type_path unresolved.type_name unresolved.from_root
+
+let pp_resolved ppf resolved = fprintf ppf "%d" resolved
+
+let pp_type pp_user_defined ppf t =
+  match t with
+  | #builtin_type as built_in_type -> pp_builtin_type ppf built_in_type
+  | `User_defined user_defined -> pp_user_defined ppf user_defined
+
+let pp_unresolved_t ppf t = pp_type pp_unresolved ppf t
+let pp_resolved_t ppf t = pp_type pp_resolved ppf t

src/compilerlib/pb_field_type.mli

@@ -128,3 +128,31 @@ type unresolved_t = unresolved t
 type resolved_t = resolved t
 
 val parse : string -> unresolved_t
+val pp_type_path : Format.formatter -> type_path -> unit
+
+val pp_builtin_type_floating_point :
+  Format.formatter -> builtin_type_floating_point -> unit
+
+val pp_builtin_type_unsigned_int :
+  Format.formatter -> builtin_type_unsigned_int -> unit
+
+val pp_builtin_type_signed_int :
+  Format.formatter -> builtin_type_signed_int -> unit
+
+val pp_builtin_type_int : Format.formatter -> builtin_type_int -> unit
+val pp_map_key_type : Format.formatter -> map_key_type -> unit
+val pp_builtin_type : Format.formatter -> builtin_type -> unit
+val pp_unresolved : Format.formatter -> unresolved -> unit
+val pp_resolved : Format.formatter -> resolved -> unit
+
+val pp_type :
+  (Format.formatter -> 'a -> unit) ->
+  Format.formatter ->
+  [ builtin_type | `User_defined of 'a ] ->
+  unit
+
+val pp_unresolved_t :
+  Format.formatter -> [ builtin_type | `User_defined of unresolved ] -> unit
+
+val pp_resolved_t :
+  Format.formatter -> [ builtin_type | `User_defined of resolved ] -> unit

src/compilerlib/pb_format_util.ml

@@ -0,0 +1,9 @@
+open Format
+
+
+(* Not available in 4.03 *)
+let pp_print_option ?(none = fun _ () -> ()) pp_v ppf = function
+  | None -> none ppf ()
+  | Some v -> pp_v ppf v
+
+let pp_none ppf () = fprintf ppf "(None)"

src/compilerlib/pb_format_util.mli

@@ -0,0 +1,4 @@
+val pp_print_option :
+  ?none:('a -> unit -> unit) -> ('a -> 'b -> unit) -> 'a -> 'b option -> unit
+
+val pp_none : Format.formatter -> unit -> unit

src/compilerlib/pb_option.ml

@@ -17,3 +17,18 @@ let get t option_name =
   match List.assoc option_name t with
   | c -> Some c
   | exception Not_found -> None
+
+let pp_constant ppf = function
+  | Constant_string s -> Format.fprintf ppf "%S" s
+  | Constant_bool b -> Format.fprintf ppf "%B" b
+  | Constant_int i -> Format.fprintf ppf "%d" i
+  | Constant_float f -> Format.fprintf ppf "%f" f
+  | Constant_litteral l -> Format.fprintf ppf "`%s`" l
+
+let pp_t ppf (name, const) =
+  Format.fprintf ppf "{@;<1 2>%S: %a@;<1 2>}" name pp_constant const
+
+let pp_set ppf set =
+  Format.fprintf ppf "[@[<v>%a@]]"
+    (Format.pp_print_list ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@,") pp_t)
+    set

src/compilerlib/pb_option.mli

@@ -28,3 +28,6 @@ val merge : set -> set -> set
     than in case of duplicates [s2] options will override [s1] options. *)
 
 val get : set -> string -> constant option
+val pp_constant : Format.formatter -> constant -> unit
+val pp_t : Format.formatter -> t -> unit
+val pp_set : Format.formatter -> set -> unit

src/compilerlib/pb_parsing_parse_tree.ml

@@ -164,3 +164,183 @@ type proto = {
 }
 (** Definition of a protobuffer message file. 
 *)
+
+[@@@warning "-44"]
+
+open Format
+open Pb_format_util
+
+let pp_message_field_label ppf label =
+  let label_str =
+    match label with
+    | `Optional -> "Optional"
+    | `Required -> "Required"
+    | `Repeated -> "Repeated"
+    | `Nolabel -> "Nolabel"
+  in
+  fprintf ppf "`%s" label_str
+
+let pp_oneof_field_label _ppf () = ()
+
+let pp_field pp_label ppf field =
+  fprintf ppf
+    "{@[<v 2>@,\
+     field_name = %S;@,\
+     field_number = %d;@,\
+     field_label = %a;@,\
+     field_type = %a;@,\
+     field_options = %a;@,\
+     }@]"
+    field.field_name field.field_number pp_label field.field_label
+    Pb_field_type.pp_unresolved_t field.field_type Pb_option.pp_set
+    field.field_options
+
+let pp_message_field ppf field = pp_field pp_message_field_label ppf field
+let pp_oneof_field ppf field = pp_field pp_oneof_field_label ppf field
+
+let pp_map_field ppf map_field =
+  fprintf ppf
+    "{@[<2>@,\
+     map_name = %S;@,\
+     map_number = %d;@,\
+     map_key_type = %a;@,\
+     map_value_type = %a;@,\
+     map_options = %a;@,\
+     }@]"
+    map_field.map_name map_field.map_number Pb_field_type.pp_map_key_type
+    map_field.map_key_type Pb_field_type.pp_unresolved_t
+    map_field.map_value_type Pb_option.pp_set map_field.map_options
+
+let pp_oneof ppf oneof =
+  fprintf ppf "{@[<2>@,oneof_name = %S;@,oneof_fields = [@[<v>%a@]];@,}@]"
+    oneof.oneof_name
+    (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";@,") pp_oneof_field)
+    oneof.oneof_fields
+
+let pp_enum_value ppf enum_value =
+  fprintf ppf "{@[<v 2>@,enum_value_name = %S;@,enum_value_int = %d;@,}@]"
+    enum_value.enum_value_name enum_value.enum_value_int
+
+let pp_enum_body_content ppf enum_body_content =
+  match enum_body_content with
+  | Enum_value enum_value -> pp_enum_value ppf enum_value
+  | Enum_option option -> Pb_option.pp_t ppf option
+
+let pp_enum ppf enum =
+  fprintf ppf
+    "{@[<v 2>@,enum_id = %d;@,enum_name = %S;@,enum_body = [@[<v>%a@]];@,}@]"
+    enum.enum_id enum.enum_name
+    (pp_print_list
+       ~pp_sep:(fun ppf () -> fprintf ppf ";@,")
+       pp_enum_body_content)
+    enum.enum_body
+
+let pp_extension_range_to ppf ext_range_to =
+  match ext_range_to with
+  | To_max -> fprintf ppf "To_max"
+  | To_number n -> fprintf ppf "(To_number %d)" n
+
+let pp_extension_range_from ppf ext_range_from = fprintf ppf "%d" ext_range_from
+
+let pp_extension_range ppf ext_range =
+  match ext_range with
+  | Extension_single_number n -> fprintf ppf "(Extension_single_number %d)" n
+  | Extension_range (from, to_) ->
+    fprintf ppf "(Extension_range (%d, %a))" from pp_extension_range_to to_
+
+let rec pp_message_body_content ppf msg_body_content =
+  match msg_body_content with
+  | Message_field field -> pp_message_field ppf field
+  | Message_map_field map_field -> pp_map_field ppf map_field
+  | Message_oneof_field oneof_field -> pp_oneof ppf oneof_field
+  | Message_sub sub_message -> pp_message ppf sub_message
+  | Message_enum enum -> pp_enum ppf enum
+  | Message_extension ext_ranges ->
+    fprintf ppf "Message_extension [@[<v>%a@]]"
+      (pp_print_list
+         ~pp_sep:(fun ppf () -> fprintf ppf ";@,")
+         pp_extension_range)
+      ext_ranges
+  | Message_reserved res_ranges ->
+    fprintf ppf "Message_reserved [@[<v>%a@]]"
+      (pp_print_list
+         ~pp_sep:(fun ppf () -> fprintf ppf ";@,")
+         pp_extension_range)
+      res_ranges
+  | Message_option option -> Pb_option.pp_t ppf option
+
+and pp_message ppf message =
+  fprintf ppf
+    "{@[<v 2>@,id = %d;@,message_name = %S;@,message_body = [@[<v>%a@]];@,}@]"
+    message.id message.message_name
+    (pp_print_list
+       ~pp_sep:(fun ppf () -> fprintf ppf ";@,")
+       pp_message_body_content)
+    message.message_body
+
+let pp_rpc ppf rpc =
+  fprintf ppf
+    "{@[<2>@,\
+     rpc_name = %S;@,\
+     rpc_options = %a;@,\
+     rpc_req_stream = %b;@,\
+     rpc_req = %a;@,\
+     rpc_res_stream = %b;@,\
+     rpc_res = %a;@,\
+     }@]"
+    rpc.rpc_name Pb_option.pp_set rpc.rpc_options rpc.rpc_req_stream
+    Pb_field_type.pp_unresolved_t rpc.rpc_req rpc.rpc_res_stream
+    Pb_field_type.pp_unresolved_t rpc.rpc_res
+
+let rec pp_service_body_content ppf service_body_content =
+  match service_body_content with
+  | Service_rpc rpc -> pp_rpc ppf rpc
+  | Service_option option -> Pb_option.pp_t ppf option
+
+and pp_service ppf service =
+  fprintf ppf "{@[<2>@,service_name = %S;@,service_body = [@[<v>%a@]];@,}@]"
+    service.service_name
+    (pp_print_list
+       ~pp_sep:(fun ppf () -> fprintf ppf ";@,")
+       pp_service_body_content)
+    service.service_body
+
+let pp_extend ppf extend =
+  fprintf ppf
+    "{@[<2>@,id = %d;@,extend_name = %S;@,extend_body = [@[<v>%a@]];@,}@]"
+    extend.id extend.extend_name
+    (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";@,") pp_message_field)
+    extend.extend_body
+
+let pp_import ppf import =
+  fprintf ppf "{@[<2>@,file_name = %S;@,public = %b;@,}@]" import.file_name
+    import.public
+
+let pp_proto ppf proto =
+  fprintf ppf
+    "{@[<v 2>@ proto_file_name = %a;@,\
+     syntax = %a;@,\
+     imports = [@[<v>%a@]];@,\
+     file_options = %a;@,\
+     package = %a;@,\
+     messages = [@[<v>%a@]];@,\
+     services = [@[<v>%a@]];@,\
+     enums = [@[<v>%a@]];@,\
+     extends = [@[<v>%a@]];@,\
+     }@]"
+    (pp_print_option ~none:pp_none pp_print_string)
+    proto.proto_file_name
+    (pp_print_option ~none:pp_none pp_print_string)
+    proto.syntax
+    (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";@,") pp_import)
+    proto.imports Pb_option.pp_set proto.file_options
+    (pp_print_option ~none:pp_none pp_print_string)
+    proto.package
+    (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";@,") pp_message)
+    proto.messages
+    (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";@,") pp_service)
+    proto.services
+    (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";@,") pp_enum)
+    proto.enums
+    (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ";@,") pp_extend)
+    proto.extends

src/tests/expectation/dune

@@ -0,0 +1,14 @@
+(executable
+ (name tests)
+ (libraries pbrt ocaml-protoc.compiler-lib)
+ (flags :standard -open Ocaml_protoc_compiler_lib))
+
+(rule
+ (with-stdout-to
+  tests.output
+  (run ./tests.exe)))
+
+(rule
+ (alias runtest)
+ (action
+  (diff tests.expected tests.output)))