Source file ppx_deriving_encoding.ml

open Ppxlib
open Ppx_deriving_encoding_lib

let str_gen ~loc ~path:_ (rec_flag, l)
    enum union ign mu force_debug rm_prefix option title description schema name modu
    camel snake pascal kebab upper lower cap wrap assoc kind def =
  let enum = match enum, union with _, true -> false | _ -> true in
  Encoding.structure ~loc ~enum ~ign ~mu ~force_debug
    ?rm_prefix ?option ?def ?title ?description ?schema ?name ?modu
    ~camel ~snake ~pascal ~kebab ~upper ~lower ~cap ~wrap ~rec_flag ~assoc ?kind l

let sig_gen ~loc ~path:_ (_rec_flag, l) name modu =
  Encoding.signature ~loc ?name ?modu l

let str_type_ext ~loc ~path:_ type_ext force_debug rm_prefix option modu
    camel snake pascal kebab upper lower cap wrap kind =
  Encoding.type_ext_structure ~loc ?modu ~force_debug ?rm_prefix ?option
    ~camel ~snake ~pascal ~kebab ~upper ~lower ~cap ~wrap ?kind type_ext

let eprefix t =
  let f = Deriving.Args.to_func t in
  Deriving.Args.of_func (fun ctx loc x k ->
    match Utils.rm_prefix_of_expr x with
    | None -> Utils.raise_error ~loc "wrong boolean argument"
    | Some x -> f ctx loc x k)

let string_option name t =
  let f = Deriving.Args.to_func t in
  Deriving.Args.of_func (fun ctx loc x k ->
    match x.pexp_desc with
    | Pexp_ident {txt=Lident x; _} when x = name -> f ctx loc None k
    | Pexp_constant Pconst_string (s, _, _) -> f ctx loc (Some s) k
    | _ -> Utils.raise_error ~loc "wrong %s argument" name)

let string_or_ident t =
  let f = Deriving.Args.to_func t in
  Deriving.Args.of_func (fun ctx loc x k ->
    match x.pexp_desc with
    | Pexp_ident {txt=Lident s; _} -> f ctx loc s k
    | Pexp_constant Pconst_string (s, _, _) -> f ctx loc s k
    | _ -> Utils.raise_error ~loc "wrong string or ident argument")

let () =
  let open Deriving in
  let args_str = Args.(
    empty
    +> flag "enum"
    +> flag "union"
    +> flag "ignore"
    +> flag "recursive"
    +> flag "debug"
    +> arg "remove_prefix" (eprefix __)
    +> arg "option" (string_or_ident __)
    +> arg "title"  __
    +> arg "description" __
    +> arg "schema" __
    +> arg "name" (estring __)
    +> arg "module_name" (estring __)
    +> flag "camel"
    +> flag "snake"
    +> flag "pascal"
    +> flag "kebab"
    +> flag "upper"
    +> flag "lower"
    +> flag "cap"
    +> flag "wrap"
    +> flag "assoc"
    +> arg "kind" ((string_option "kind") __)
    +> arg "def" (estring __)
  ) in
  let args_sig = Args.(
    empty
    +> arg "name" (estring __)
    +> arg "module_name" (estring __)
  ) in
  let args_type_ext = Args.(
    empty
    +> flag "debug"
    +> arg "remove_prefix" (eprefix __)
    +> arg "option" (string_or_ident __)
    +> arg "module_name" (estring __)
    +> flag "camel"
    +> flag "snake"
    +> flag "pascal"
    +> flag "kebab"
    +> flag "upper"
    +> flag "lower"
    +> flag "cap"
    +> flag "wrap"
    +> arg "kind" ((string_option "kind") __)
  ) in
  let str_type_decl = Generator.make args_str str_gen in
  let sig_type_decl = Generator.make args_sig sig_gen in
  let str_type_ext = Generator.make args_type_ext str_type_ext in
  ignore @@ add "encoding" ~str_type_decl ~sig_type_decl ~str_type_ext;
  ignore @@ add "json_encoding" ~str_type_decl ~sig_type_decl;