Merge pull request #4 from ahrefs/all_of

Basic allOf support

README.md

@@ -67,4 +67,4 @@ You can call `jsonschema2atd` and `atdgen` in your `dune` file to generate OCaml
 - [X] OneOf (Only serialization is supported)
 - [ ] not
 - [ ] anyOf
-- [ ] allOf
+- [X] allOf

lib/generator.ml

@@ -6,18 +6,39 @@ let record_field_name str =
   let cleaned_field_name = Utils.sanitize_name str in
   if String.equal str cleaned_field_name then str else sprintf {|%s <json name="%s">|} cleaned_field_name str
 
-let define_top_level name type_ = sprintf "type %s = %s\n\n" (type_name name) type_
+let define_type name type_ = sprintf "type %s = %s\n" (type_name name) type_
 
 let process_int_type schema =
   match schema.format with
   | None | Some `Int32 -> "int"
   | Some `Int64 -> "int64"
   | _ -> failwith "int has unextected format"
 
-let get_ref (ref : ref_) =
-  match ref |> String.split_on_char '/' |> List.rev with
-  | type_name :: _ -> type_name
-  | _ -> failwith (Printf.sprintf "%s: can't resolve ref type name" ref)
+let get_ref_name ref =
+  match String.split_on_char '/' ref with
+  (* OpenAPI defs *)
+  | [ "#"; "components"; "schemas"; type_name ] -> type_name
+  (* JSON Schema defs *)
+  | [ "#"; "$defs"; type_name ] -> type_name
+  | _ ->
+    failwith
+      (Printf.sprintf "Unsupported ref value: %s. Supported ref URI are: #/components/schemas/* and #/$defs/*" ref)
+
+let output = Buffer.create 16
+let input_toplevel_schemas = ref []
+
+let get_schema_by_ref ~schema ref =
+  let defs =
+    match schema.defs with
+    | None -> !input_toplevel_schemas
+    | Some defs -> defs @ !input_toplevel_schemas
+  in
+  List.find_map
+    (function
+      | name, schema when String.equal (get_ref_name ref) name -> Some schema
+      | _ -> None
+      )
+    defs
 
 let rec ocaml_value_of_json = function
   | (`Bool _ | `Float _ | `Int _ | `Null) as json -> Yojson.Basic.to_string json
@@ -36,7 +57,65 @@ let make_atd_default_value enum json_value =
 
 let nullable = Printf.sprintf "%s nullable"
 
+let merge_all_of schema =
+  match schema.all_of with
+  | None -> schema
+  | Some [] -> failwith "empty allOf is unexpected"
+  | Some all_of ->
+    let ref_schemas =
+      List.filter_map
+        (function
+          | Obj schema -> Some schema
+          | Ref ref -> get_schema_by_ref ~schema ref
+          )
+        all_of
+    in
+    let schemas = schema :: ref_schemas in
+    let take_first_opt get_fn =
+      match schemas |> List.filter_map get_fn with
+      | [] -> None
+      | first :: _ -> Some first
+    in
+    let merge_lists get_fn = schemas |> List.map get_fn |> List.flatten in
+    let merge_opt_lists get_fn = schemas |> List.filter_map get_fn |> List.flatten |> Utils.nonempty_list_opt in
+    {
+      schema = take_first_opt (fun schema -> schema.schema);
+      all_of = merge_opt_lists (fun schema -> schema.all_of);
+      any_of = merge_opt_lists (fun schema -> schema.any_of);
+      one_of = merge_opt_lists (fun schema -> schema.one_of);
+      not = take_first_opt (fun schema -> schema.not);
+      items = take_first_opt (fun schema -> schema.items);
+      properties = merge_opt_lists (fun schema -> schema.properties);
+      additional_properties = take_first_opt (fun schema -> schema.additional_properties);
+      enum =
+        schemas
+        |> List.filter_map (fun schema -> schema.enum)
+        |> Utils.shortest_list
+        |> Option.value ~default:[]
+        |> Utils.nonempty_list_opt;
+      max_length = take_first_opt (fun schema -> schema.max_length);
+      min_length = take_first_opt (fun schema -> schema.min_length);
+      pattern = take_first_opt (fun schema -> schema.pattern);
+      max_items = take_first_opt (fun schema -> schema.max_items);
+      min_items = take_first_opt (fun schema -> schema.min_items);
+      unique_items = take_first_opt (fun schema -> schema.unique_items);
+      max_contains = take_first_opt (fun schema -> schema.max_contains);
+      min_contains = take_first_opt (fun schema -> schema.min_contains);
+      max_properties = take_first_opt (fun schema -> schema.max_properties);
+      min_properties = take_first_opt (fun schema -> schema.min_properties);
+      required = merge_lists (fun schema -> schema.required);
+      dependent_required = merge_lists (fun schema -> schema.dependent_required);
+      format = take_first_opt (fun schema -> schema.format);
+      defs = merge_opt_lists (fun schema -> schema.defs);
+      title = take_first_opt (fun schema -> schema.title);
+      typ = take_first_opt (fun schema -> schema.typ);
+      description = take_first_opt (fun schema -> schema.description);
+      default = take_first_opt (fun schema -> schema.default);
+      nullable = schemas |> List.exists (fun schema -> schema.nullable);
+    }
+
 let rec process_schema_type ~ancestors (schema : schema) =
+  let schema = merge_all_of schema in
   let maybe_nullable type_ = if schema.nullable then nullable type_ else type_ in
   match schema.one_of with
   | Some schemas -> process_one_of ~ancestors schemas
@@ -51,8 +130,7 @@ let rec process_schema_type ~ancestors (schema : schema) =
   | Some String -> maybe_nullable "string"
   | Some Boolean -> maybe_nullable "bool"
   | Some Array -> maybe_nullable (process_array_type ~ancestors schema |> String.concat " ")
-  | Some Object ->
-    if schema.nullable then process_nested_schema_type ~ancestors schema else process_object_type ~ancestors schema
+  | Some Object -> process_object_type ~ancestors schema
   | None ->
     (* fallback to untyped if schema type is not defined *)
     maybe_nullable "json"
@@ -62,16 +140,14 @@ and process_array_type ~ancestors schema =
   | Some schema_or_ref -> [ make_type_from_schema_or_ref ~ancestors schema_or_ref; "list" ]
   | None -> failwith "items is not specified for array"
 
-and toplevel_definitions = Buffer.create 16
-
 and process_nested_schema_type ~ancestors schema =
-  match schema with
+  match merge_all_of schema with
   | { one_of = Some _; _ } | { typ = Some Object; properties = Some _; _ } | { enum = Some _; _ } ->
     let nested_type_name = concat_camelCase (List.rev ancestors) in
-    let nested = define_top_level nested_type_name (process_schema_type ~ancestors schema) in
-    Buffer.add_string toplevel_definitions nested;
+    let nested = define_type nested_type_name (process_schema_type ~ancestors schema) in
+    Buffer.add_string output (nested ^ "\n");
     type_name nested_type_name
-  | _ as schema -> process_schema_type ~ancestors schema
+  | _ -> process_schema_type ~ancestors schema
 
 and process_object_type ~ancestors schema =
   let is_required field_name = List.exists (String.equal field_name) schema.required in
@@ -92,13 +168,13 @@ and make_type_from_schema_or_ref ~ancestors (schema_or_ref : schema or_ref) =
   match schema_or_ref, ancestors with
   | Obj schema, ([] | [ _ ]) -> process_schema_type ~ancestors schema
   | Obj schema, ancestors -> process_nested_schema_type ~ancestors schema
-  | Ref ref_, _ -> type_name (get_ref ref_)
+  | Ref ref_, _ -> type_name (get_ref_name ref_)
 
 and process_one_of ~ancestors (schemas_or_refs : schema or_ref list) =
   let determine_variant_name = function
-    | Ref ref_ -> variant_name (get_ref ref_)
+    | Ref ref_ -> variant_name (get_ref_name ref_)
     | Obj schema ->
-    match schema.typ with
+    match (merge_all_of schema).typ with
     | Some Array -> concat_camelCase (process_array_type ~ancestors schema)
     | Some Object -> "Json"
     | _ -> variant_name (process_schema_type ~ancestors schema)
@@ -117,30 +193,41 @@ and process_enums enums =
   sprintf "[\n%s\n]" variants
 
 let process_schemas (schemas : (string * schema or_ref) list) =
-  let atd_schemas =
-    List.fold_left
-      (fun acc (name, schema_or_ref) ->
-        define_top_level name (make_type_from_schema_or_ref ~ancestors:[ name ] schema_or_ref) :: acc
-      )
-      [] schemas
-  in
-  String.concat "" (Buffer.contents toplevel_definitions :: atd_schemas)
-
-let base = {|
+  List.fold_left
+    (fun acc (name, schema_or_ref) ->
+      define_type name (make_type_from_schema_or_ref ~ancestors:[ name ] schema_or_ref) :: acc
+    )
+    [] schemas
+
+let base =
+  {|(* Generated by jsonschema2atd *)
 type json <ocaml module="Yojson.Basic" t="t"> = abstract
 type int64 = int <ocaml repr="int64">
 |}
 
+let make_atd_of_schemas schemas =
+  input_toplevel_schemas :=
+    List.filter_map
+      (function
+        | _name, Ref _ -> None
+        | name, Obj schema -> Some (name, schema)
+        )
+      schemas;
+  Buffer.clear output;
+  Buffer.add_string output (base ^ "\n");
+  Buffer.add_string output (String.concat "\n" (process_schemas schemas));
+  Buffer.contents output
+
 let make_atd_of_jsonschema input =
   let schema = Json_schema_j.schema_of_string input in
   let root_type_name = Option.value ~default:"root" schema.title in
-  base ^ "\n" ^ process_schemas [ root_type_name, Obj schema ]
+  make_atd_of_schemas [ root_type_name, Obj schema ]
 
 let make_atd_of_openapi input =
   let root = Openapi_j.root_of_string input in
   match root.components with
   | None -> failwith "components are empty"
   | Some components ->
   match components.schemas with
-  | Some schemas -> base ^ "\n" ^ process_schemas schemas
+  | Some schemas -> make_atd_of_schemas schemas
   | None -> failwith "components schemas are empty"

lib/json_schema.atd

@@ -40,7 +40,7 @@ type schema = {
   ~schema <json name="$schema">: string nullable;
 
   (* 10.2.1 keywords for applying subschemas with logic *)
-  ~all_of <json name="allOf">: schema nonempty_list nullable;
+  ~all_of <json name="allOf">: schema or_ref nonempty_list nullable;
   ~any_of <json name="anyOf">: schema nonempty_list nullable;
   ~one_of <json name="oneOf">: schema or_ref nonempty_list nullable;
   ~not : schema nullable;
@@ -86,6 +86,9 @@ type schema = {
   (* 7. semantic content with "format" *)
   ~format : format nullable;
 
+  (* 8.2.4. re-usable JSON Schemas *)
+  ~defs <json name="$defs">: (string * schema) list <json repr="object"> nullable;
+
   (* 9. basic metadata annotations *)
   ~title : string nullable;
   ~description : string nullable;

lib/utils.ml

@@ -88,3 +88,13 @@ struct
   let compare = T.compare
   let equal a b = T.compare a b = 0
 end
+
+let hd_opt = function
+  | [] -> None
+  | first :: _ -> Some first
+
+let shortest_list lists = lists |> List.sort (fun a b -> compare (List.length a) (List.length b)) |> hd_opt
+
+let nonempty_list_opt = function
+  | [] -> None
+  | non_empty_list -> Some non_empty_list

tests/all_of.ml

@@ -3,28 +3,28 @@ open Base
 
 let simple_test _ =
   let input =
-    {| {
+    {|{
     "dummy": {
       "type": "object",
       "properties": {
-        "field": {
-          "id": "string"
+        "id": {
+          "type": "string"
         }
       },
       "allOf": [
         {
           "type": "object",
           "properties": {
-            "field": {
-              "name": "string"
+            "name": {
+                "type": "string"
             }
           }
         },
         {
           "type": "object",
           "properties": {
-            "field": {
-              "surname": "string"
+            "surname": {
+                "type": "string"
             }
           }
         }
@@ -38,9 +38,66 @@ let simple_test _ =
       ?id: string option;
       ?name: string option;
       ?surname: string option;
+     }
   |}
   in
   assert_schema input output
 
-let suite = "allOf" >::: [ "simple test" >:: simple_test ]
+let with_nested _ =
+  let input =
+    {|{
+      "MappingType": {
+        "type": "string",
+        "enum": [
+          "value",
+          "range",
+          "regex",
+          "special"
+        ]
+      },
+      "RangeMap": {
+        "type": "object",
+        "required": [
+          "type",
+          "options"
+        ],
+        "properties": {
+          "type": {
+            "type": "string",
+            "allOf": [
+              {
+                "$ref": "#/components/schemas/MappingType"
+              },
+              {
+                "enum": [
+                  "range"
+                ]
+              }
+            ]
+          }
+        }
+      }
+}|}
+  in
+  let output =
+    {|
+    type rangeMapType = [
+      | Range <json name="range">
+    ]
+
+    type rangeMap = {
+      type_ <json name="type">: rangeMapType;
+    }
+
+    type mappingType = [
+      | Value <json name="value">
+      | Range <json name="range">
+      | Regex <json name="regex">
+      | Special <json name="special">
+    ]
+  |}
+  in
+  assert_schema input output
+
+let suite = "allOf" >::: [ "simple test" >:: simple_test; "with nested" >:: with_nested ]
 let () = run_test_tt_main suite

tests/base.ml

@@ -6,7 +6,7 @@ let openapi_json_template schemas =
     schemas
 
 let replace_whitespace str = Str.global_replace (Str.regexp "[ \t\n\r]+") "" str
-let remove_prelude str = Str.global_replace (Str.regexp Generator.base) "" str
+let remove_prelude str = Str.global_replace (Str.regexp (Str.quote Generator.base)) "" str
 let test_strings_cmp a b = String.equal (replace_whitespace a) (replace_whitespace b)
 
 let assert_schema input output =

tests/dune

@@ -1,5 +1,6 @@
 (tests
  (names
+  all_of
   base
   defaults
   enums