atdgen: add support for wrapped keys for <json repr = "object"> in me…

…lange

CHANGES.md

@@ -4,6 +4,7 @@ Unreleased
 * atdgen: Breaking change, migrate from Bucklescript to Melange (#375)
 * atdd: Workaround d compiler bug regarding declaration order when using aliases (#393)
         Algebraic data types (SumType) now uses `alias this` syntax.
+* atdgen: Add support for wrapped keys when using `json repr="object`
 
 2.15.0 (2023-10-26)
 -------------------

atdgen-codec-runtime/src/decode.ml

@@ -38,12 +38,12 @@ let array f = function
   | `List l -> Array.map f (Array.of_list l)
   | _ -> raise DecoderError
 
-let obj_list f = function
-  | `Assoc l -> List.map (fun (k, v) -> k, f v) l
+let obj_list ~decode_name f = function
+  | `Assoc l -> List.map (fun (k, v) -> decode_name (`String k), f v) l
   | _ -> raise DecoderError
 
-let obj_array f = function
-  | `Assoc l -> Array.map (fun (k, v) -> k, f v) (Array.of_list l)
+let obj_array ~decode_name f = function
+  | `Assoc l -> Array.map (fun (k, v) -> decode_name (`String k), f v) (Array.of_list l)
   | _ -> raise DecoderError
 
 let optional f j =

atdgen-codec-runtime/src/decode.mli

@@ -14,8 +14,8 @@ val string : string t
 val optional : 'a t -> 'a option t
 val list : 'a t -> 'a list t
 val array : 'a t -> 'a array t
-val obj_list : 'a t -> (string * 'a) list t
-val obj_array : 'a t -> (string * 'a) array t
+val obj_list : decode_name:'k t -> 'a t -> ('k * 'a) list t
+val obj_array : decode_name:'k t -> 'a t -> ('k * 'a) array t
 
 (* a field that should be present *)
 val field : string -> 'a t -> 'a t

atdgen-codec-runtime/src/encode.ml

@@ -17,55 +17,62 @@ let array f xs = `List (Array.to_list (Array.map f xs))
 let int32 s = `String (Int32.to_string s)
 let int64 s = `String (Int64.to_string s)
 
-type ('a, 'b) spec =
-  { name: string
+type ('k, 'a, 'b) spec =
+  { name: 'k
   ; data: 'a
+  ; encode_name: 'k t
   ; encode: 'b t
   }
 
-type 'a field_spec =
-  | Optional of ('a option, 'a) spec * 'a option
-  | Required of ('a, 'a) spec * 'a option
+type ('k, 'a) field_spec =
+  | Optional of ('k, 'a option, 'a) spec * 'a option
+  | Required of ('k, 'a, 'a) spec * 'a option
 
-type field = F : 'a field_spec -> field
+type field = F : ('k, 'a) field_spec -> field
 
-let field ?default encode ~name data =
+let field ?default ~encode_name encode ~name data =
   F (Required (
     { name
     ; data
+    ; encode_name
     ; encode
     }, default
   ))
 
-let field_o ?default encode ~name data =
+let field_o ?default ~encode_name encode ~name data =
   F (Optional (
     { name
     ; data
+    ; encode_name
     ; encode
     }, default
   ))
 
+let as_string json =
+  match json with
+  | `String s -> s | _ -> (* rejected at atd parsing *) assert false
+
 let obj fields =
   `Assoc (
     List.fold_left (fun acc (F f) ->
       match f with
-      | Required ({ name; data; encode}, None) ->
-          (name, encode data)::acc
-      | Required ({ name; data; encode}, Some default) ->
+      | Required ({ name; data; encode_name; encode }, None) ->
+          (encode_name name |> as_string, encode data)::acc
+      | Required ({ name; data; encode_name; encode }, Some default) ->
           if default = data then
             acc
           else
-            (name, encode data)::acc
-      | Optional ({ name; data; encode}, default) ->
+            (encode_name name |> as_string, encode data)::acc
+      | Optional ({ name; data; encode_name; encode }, default) ->
           match data, default with
           | None, _ -> acc
           | Some s, Some default ->
               if s = default then
                 acc
               else
-                (name, encode s)::acc
+                (encode_name name |> as_string, encode s)::acc
           | Some s, None ->
-              (name, encode s)::acc
+              (encode_name name |> as_string, encode s)::acc
     ) [] fields
   )
 

atdgen-codec-runtime/src/encode.mli

@@ -19,8 +19,8 @@ val int64 : int64 t
 
 type field
 
-val field : ?default:'a -> 'a t -> name:string -> 'a -> field
-val field_o : ?default:'a -> 'a t -> name:string -> 'a option -> field
+val field : ?default:'a -> encode_name:'k t -> 'a t -> name:'k -> 'a -> field
+val field_o : ?default:'a -> encode_name:'k t -> 'a t -> name:'k -> 'a option -> field
 
 val obj : field list -> Json.t
 

atdgen/src/omelange_emit.ml

@@ -172,11 +172,14 @@ let rec make_reader ?type_annot p (x : Oj_mapping.t) : Indent.t list =
            ; Line ")"
            ]
        | Object ->
-           let _k, v = Ox_emit.get_assoc_type p.deref loc x in (* TODO key wrap *)
-           [ Line (sprintf "%s ("
+           let k, v = Ox_emit.get_assoc_type p.deref loc x in
+           [ Line (sprintf "%s ~decode_name:("
                      (match o with
                       | List -> decoder_ident "obj_list"
                       | Array -> decoder_ident "obj_array"))
+           ; Block (make_reader p k)
+           ; Line ")"
+           ; Line "("
            ; Block (make_reader p v)
            ; Line ")"
            ]
@@ -445,7 +448,7 @@ let rec make_writer ?type_annot p (x : Oj_mapping.t) : Indent.t list =
            ; Line ")"
            ]
        | Object ->
-           let _k, v = Ox_emit.get_assoc_type p.deref loc x in
+           let k, v = Ox_emit.get_assoc_type p.deref loc x in
            [ Line (sprintf "%s (fun (t : %s) ->"
                encoder_make (type_annot_str type_annot))
            ; Block
@@ -459,12 +462,16 @@ let rec make_writer ?type_annot p (x : Oj_mapping.t) : Indent.t list =
                    ; Block
                        [ Line (encoder_ident "field")
                        ; Block
-                           [ Line "("
+                           [ Line (sprintf "~encode_name:")
+                           ; Line "("
+                           ; Block (make_writer p k)
+                           ; Line ")"
+                           ; Line "("
                            ; Block (make_writer p v)
                            ; Line ")"
                            ]
                        ; Block
-                           [ Line "~name:key" (* TODO unwrap keys? *)
+                           [ Line "~name:key"
                            ; Line "value";
                            ]
                        ]
@@ -533,7 +540,8 @@ and make_record_writer p a _record_kind =
                   assert false
             )
           ; Block
-              [ Line "("
+              [ Line (sprintf "~encode_name:%s" (encoder_ident "string"))
+              ; Line "("
               ; Inline (make_writer p (
                   if unwrapped then
                     f_value

atdgen/test/melange/melangespec.atd

@@ -108,3 +108,7 @@ type variant2 = [
   | A
   | C
 ] <ocaml repr="classic">
+
+type int_object =
+   ( string wrap <ocaml t="int" wrap="int_of_string" unwrap="string_of_int">
+   * int) list <json repr="object">

atdgen/test/melange/melangespec_j.expected.ml

@@ -52,6 +52,8 @@ type label = Melangespec_t.label
 
 type labeled = Melangespec_t.labeled = { flag: valid; lb: label; count: int }
 
+type int_object = Melangespec_t.int_object
+
 type from_module_a = A_t.from_module_a
 
 type b = Melangespec_t.b = { thing: int }
@@ -2332,6 +2334,57 @@ let read_labeled = (
 )
 let labeled_of_string s =
   read_labeled (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
+let write__x_2a90d8e = (
+  fun ob x -> (
+    let x = ( string_of_int ) x in (
+      Yojson.Safe.write_string
+    ) ob x)
+)
+let string_of__x_2a90d8e ?(len = 1024) x =
+  let ob = Buffer.create len in
+  write__x_2a90d8e ob x;
+  Buffer.contents ob
+let read__x_2a90d8e = (
+  fun p lb ->
+    let x = (
+      Atdgen_runtime.Oj_run.read_string
+    ) p lb in
+    ( int_of_string ) x
+)
+let _x_2a90d8e_of_string s =
+  read__x_2a90d8e (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
+let write__x_946c399 = (
+  Atdgen_runtime.Oj_run.write_assoc_list (
+    write__x_2a90d8e
+  ) (
+    Yojson.Safe.write_int
+  )
+)
+let string_of__x_946c399 ?(len = 1024) x =
+  let ob = Buffer.create len in
+  write__x_946c399 ob x;
+  Buffer.contents ob
+let read__x_946c399 = (
+  Atdgen_runtime.Oj_run.read_assoc_list (
+    read__x_2a90d8e
+  ) (
+    Atdgen_runtime.Oj_run.read_int
+  )
+)
+let _x_946c399_of_string s =
+  read__x_946c399 (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
+let write_int_object = (
+  write__x_946c399
+)
+let string_of_int_object ?(len = 1024) x =
+  let ob = Buffer.create len in
+  write_int_object ob x;
+  Buffer.contents ob
+let read_int_object = (
+  read__x_946c399
+)
+let int_object_of_string s =
+  read_int_object (Yojson.Safe.init_lexer ()) (Lexing.from_string s)
 let write_from_module_a = (
   A_j.write_from_module_a
 )