atdgen_codec_runtime.ml

module Encode = struct
  include Json.Encode

  type 'a t = 'a -> Js.Json.t

  type field = string * Js.Json.t

  let unit () = null

  let make f = f

  let encode f x = f x

  let obj = object_

  let int64 s = string (Int64.to_string s)

  let int32 s = string (Int32.to_string s)

  let field ?default:_ encode ~name data = (name, encode data)

  let field_o ?default encode ~name data =
    if Belt.Option.isSome data
    then (name, data |. Belt.Option.getExn |. encode)
    else
      ( name
      , match default with
        | Some data ->
            encode data
        | None ->
            null )


  let constr0 = string

  let constr1 s f x = pair Json_encode.string f (s, x)

  let contramap f g b = g (f b)

  let option_as_constr f = function
    | None ->
        constr0 "None"
    | Some s ->
        constr1 "Some" f s
end

module Decode = struct
  include Json.Decode

  type 'a t = Js.Json.t -> 'a

  let make f = f

  exception DecoderError

  let decode f json = f json

  let fieldOptional s f json =
    match Js.Json.classify json with
    | JSONObject obj ->
        Js.Dict.get obj s |. Belt.Option.map f
    | _ ->
        failwith "Expected object"


  let fieldDefault s default f =
    fieldOptional s f
    |> map (function
           | None ->
               default
           | Some s ->
               s )


  let enum l json =
    match Js.Json.classify json with
    | JSONString s -> (
      match Belt.List.getAssoc l s ( = ) with
      | Some (`Single a) ->
          a
      | _ ->
          raise DecoderError )
    | JSONArray [|s; args|]
      when Js.typeof s = "string" -> (
      match Belt.List.getAssoc l (Obj.magic s) ( = ) with
      | Some (`Decode d) ->
          decode d args
      | _ ->
          raise DecoderError )
    | _ ->
        raise DecoderError


  let obj_array f json =
    match Js.Json.classify json with
    | JSONObject obj ->
        Js.Dict.entries obj |. Belt.Array.map (fun (k, v) -> (k, f v))
    | _ ->
        raise DecoderError


  let obj_list f json =
    match Js.Json.classify json with
    | JSONObject obj ->
        Js.Dict.entries obj
        |. Belt.Array.map (fun (k, v) -> (k, f v))
        |. Belt.List.fromArray
    | _ ->
        raise DecoderError


  let unit x = if Obj.magic x == Js.null then () else raise DecoderError

  let option_as_constr f =
    enum [("None", `Single None); ("Some", `Decode (map (fun x -> Some x) f))]


  let nullable f json =
    Obj.magic json |. Js.Nullable.toOption |. Belt.Option.map f
end

test.ml

open Jest

type 'a test =
  { name : string
  ; to_yojson : 'a -> Js.Json.t
  ; of_yojson : Js.Json.t -> 'a
  ; data : 'a }

type test' = T : 'a test -> test'

let test_decode ~name ~yojson ~buckle ~data =
  T
    { name
    ; to_yojson = Atdgen_codec_runtime.Encode.encode yojson
    ; of_yojson = Atdgen_codec_runtime.Decode.decode buckle
    ; data }


let test_encode ~name ~yojson ~buckle ~data =
  T
    { name
    ; to_yojson = Atdgen_codec_runtime.Encode.encode buckle
    ; of_yojson = Atdgen_codec_runtime.Decode.decode yojson
    ; data }


let run_test (T t) =
  let open Expect in
  let open! Expect.Operators in
  let json = t.to_yojson t.data in
  let data' = t.of_yojson json in
  test t.name (fun () -> expect t.data |> toEqual data')


let run_tests tests = List.iter run_test tests

let _ =
  describe "tests" (fun () ->
      run_tests
        [ test_decode
            ~name:"decode record"
            ~yojson:Bucklespec_bs.write_labeled
            ~buckle:Bucklespec_bs.read_labeled
            ~data:{Bucklespec_t.flag = false; lb = "foo bar"; count = 123}
        ; test_encode
            ~name:"encode record"
            ~yojson:Bucklespec_bs.read_labeled
            ~buckle:Bucklespec_bs.write_labeled
            ~data:{Bucklespec_t.flag = false; lb = "foo bar"; count = 123}
        ; test_decode
            ~name:"decode variant"
            ~yojson:Bucklespec_bs.write_simple_vars
            ~buckle:Bucklespec_bs.read_simple_vars
            ~data:[`Foo (123, 456); `Bar; `Foobar (); `Foo_id (`Id "testing")]
        ; test_encode
            ~name:"encode variant"
            ~yojson:Bucklespec_bs.read_simple_vars
            ~buckle:Bucklespec_bs.write_simple_vars
            ~data:[`Foo (123, 456); `Bar; `Foobar (); `Foo_id (`Id "testing")]
        ] )