Source file encoding.ml

open Ppxlib
open Ast_builder.Default
open Utils

module SSet = Set.Make(String)

let unit_rec_encoding = ref SSet.empty

let case_expr ~loc ?(is_record=false) ?is_tuple ~kind ?(typ=`Cons) ?key ~name ?(rm_prefix=0)
    ?(empty=false) ?(singleton=false) enc =
  let pconstruct ~loc p = match typ with
    | `Cons -> ppat_construct ~loc (llid ~loc name) p
    | `Variant -> ppat_variant ~loc name p in
  let econstruct ~loc e = match typ with
    | `Cons -> pexp_construct ~loc (llid ~loc name) e
    | `Variant -> pexp_variant ~loc name e in
  let key = match key, typ with
    | Some key, _ -> key
    | _, `Cons -> String.uncapitalize_ascii @@ remove_prefix name rm_prefix
    | _, `Variant -> remove_prefix name rm_prefix in
  let kind_enc = match kind with
    | None, _ -> None
    | Some kind, kind_label ->
      let kind_label = match kind_label with None -> "kind" | Some k -> k in
      let kind = match kind with "" -> key | k -> k in
      Some (enc_apply ~loc "obj1" [
          enc_apply ~loc "req" [
            estring ~loc kind_label;
            enc_apply ~loc "constant" [ estring ~loc kind ] ] ]) in
  let ve, vp = match enc, is_tuple with
    | None, _ -> None, None
    | Some _, None ->
      let v = new_var () in
      Some (evar ~loc v), Some (pvar ~loc v)
    | Some _, Some i ->
      let vs = List.init i (fun _ -> new_var ()) in
      Some (pexp_tuple ~loc (List.map (evar ~loc) vs)),
      Some (ppat_tuple ~loc (List.map (pvar ~loc) vs)) in
  let enc = match kind_enc, enc, empty with
    | None, None, true -> enc_var ~loc "empty"
    | None, None, false -> enc_apply ~loc "constant" [ estring ~loc key ]
    | None, Some enc, _ | Some enc, None, _ -> enc
    | Some kenc, Some enc, _ -> enc_apply ~loc "merge_objs" [kenc; enc] in
  let rhs_to = match is_record, ve, kind with
    | true, Some v, (None, _) -> esome (econstruct ~loc (Some v))
    | true, Some v, (Some _, _) -> esome (pexp_tuple ~loc [
        eunit ~loc;
        econstruct ~loc (Some v)])
    | _, None, _ -> esome (eunit ~loc)
    | _, Some v, (None, _) -> esome v
    | _, Some v, (Some _, _) -> esome (pexp_tuple ~loc [ eunit ~loc; v ]) in
  let construct =
    if not singleton then
      pexp_function ~loc [
        case ~guard:None
          ~lhs:(pconstruct ~loc vp)
          ~rhs:rhs_to;
        case ~guard:None
          ~lhs:(ppat_any ~loc)
          ~rhs:(enone ~loc)
      ]
    else
      pexp_fun (pconstruct ~loc vp) rhs_to in
  let destruct = match is_record, ve, vp, kind with
    | true, Some ve, Some vp, _ ->
      pexp_function ~loc [
        case ~guard:None
          ~lhs:(match kind with
              | (None, _) -> pconstruct ~loc (Some vp)
              | (Some _, _) -> ppat_tuple ~loc [
                  punit ~loc;
                  pconstruct ~loc (Some vp) ])
          ~rhs:(econstruct ~loc (Some ve));
        case ~guard:None
          ~lhs:(ppat_any ~loc)
          ~rhs:(eapply ~loc (evar ~loc "failwith") [ estring ~loc "wrong local record" ])
      ]
    | _, None, _, _ | _, _, None, _ ->
      pexp_fun (punit ~loc) (econstruct ~loc None)
    | _, Some ve, Some vp, (None, _) -> pexp_fun vp (econstruct ~loc (Some ve))
    | _, Some ve, Some vp, (Some _, _) ->
      pexp_fun (ppat_tuple ~loc [ punit ~loc; vp ])
        (econstruct ~loc (Some ve)) in
  enc, construct, destruct

let def_expr ?title ?description ?schema ~name e =
  let loc = e.pexp_loc in
  let describe e =
    let title = Option.fold ~none:(enone ~loc) ~some:esome title in
    let description = Option.fold ~none:(enone ~loc) ~some:esome description in
    pexp_apply ~loc (evar ~loc (enc_mod "def")) [
      Nolabel, estring ~loc name;
      Optional "title", title;
      Optional "description", description;
      Nolabel, e ] in
  let add_schema e schema =
    pexp_apply ~loc (evar ~loc (enc_mod "conv")) [
      Nolabel, pexp_fun (pvar ~loc "x") (evar ~loc "x");
      Nolabel, pexp_fun (pvar ~loc "x") (evar ~loc "x");
      Labelled "schema", schema;
      Nolabel, e ] in
  match title, description, schema with
  | None, None , None -> e
  | None, None, Some schema -> add_schema e schema
  | _, _, None -> describe e
  | _, _, Some schema -> describe (add_schema e schema)

let ignore_expr ?(ign=false) e =
  let loc = e.pexp_loc in
  if not ign then e
  else
    enc_apply ~loc "conv" [
      pexp_fun (pvar ~loc "x") (pexp_tuple ~loc [evar ~loc "x"; eunit ~loc]);
      pexp_fun (ppat_tuple ~loc [pvar ~loc "x"; punit ~loc]) (evar ~loc "x");
      enc_apply ~loc "merge_objs" [e; enc_var ~loc "unit"]
    ]

let mu_expr ?(mu=false) ~name e =
  let loc = e.pexp_loc in
  if not mu then e
  else
    enc_apply ~loc "mu" [
      estring ~loc name;
      pexp_fun (pvar ~loc (enc_name name)) e ]

let result_expr ok err =
  let ok_loc, err_loc = ok.pexp_loc, err.pexp_loc in
  enc_apply ~loc:ok_loc "union" [ elist ~loc:ok_loc [
        enc_apply ~loc:ok_loc "case" [
          ok;
          pexp_function ~loc:ok_loc [
            case ~guard:None ~lhs:(ppat_construct ~loc:ok_loc (llid ~loc:ok_loc "Ok") (Some (pvar ~loc:ok_loc "x")))
              ~rhs:(esome (evar ~loc:ok_loc "x"));
            case ~guard:None ~lhs:(ppat_any ~loc:ok_loc) ~rhs:(enone ~loc:ok_loc) ];
          pexp_fun (pvar ~loc:ok_loc "x") (pexp_construct ~loc:ok_loc (llid ~loc:ok_loc "Ok") (Some (evar ~loc:ok_loc "x")))
        ];
        enc_apply ~loc:err_loc "case" [
          enc_apply ~loc:err_loc "obj1" [ enc_apply ~loc:err_loc "req" [estring ~loc:err_loc "error"; err] ];
          pexp_function ~loc:err_loc [
            case ~guard:None ~lhs:(ppat_construct ~loc:err_loc (llid ~loc:err_loc "Error") (Some (pvar ~loc:err_loc "x")))
              ~rhs:(esome (evar ~loc:err_loc "x"));
            case ~guard:None ~lhs:(ppat_any ~loc:err_loc) ~rhs:(enone ~loc:err_loc) ];
          pexp_fun (pvar ~loc:err_loc "x") (pexp_construct ~loc:err_loc (llid ~loc:err_loc "Error") (Some (evar ~loc:err_loc "x")))
        ]
      ]
    ]

let rec core ?opt ?assoc ?enum ?obj ?enc ?obj1 ?option ?ign ?camel ?snake ?set ?map ?is_mu ~wrap c =
  let loc = c.ptyp_loc in
  let {co_assoc; co_enum; co_obj; co_enc; co_obj1; co_rm_prefix ; co_set; co_map; _} =
    core_attrs ?assoc ?enum ?obj ?enc ?obj1 ?set ?map c.ptyp_attributes in
  match co_enc with
  | Some e -> e
  | None ->
    let e = match c.ptyp_desc with
      | Ptyp_any -> enc_var ~loc "any_ezjson_value"
      | Ptyp_var v -> evar ~loc ("_" ^ enc_name v)
      | Ptyp_constr ({txt; _}, _) when is_mu = Some (Longident.name txt) ->
        evar ~loc (enc_name (Longident.name txt))
      | Ptyp_constr ({txt; _}, l) ->
        constr ~loc ?opt ?assoc:co_assoc ?option ?set:co_set ?map:co_map ?is_mu ~wrap (Longident.name txt) l
      | Ptyp_tuple l -> tuple ~loc ?obj:co_obj ?option ?camel ?snake ?is_mu ~wrap l
      | Ptyp_variant (l, _, _) ->
        variant ~loc ?enum:co_enum ?option ?rm_prefix:co_rm_prefix ~parent:c ?is_mu ~wrap l
      | Ptyp_object (l, _) -> object_expr ~loc ?option ?camel ?snake ?is_mu ~wrap l
      | _ -> raise_error ~loc "not handled" in
    match co_obj1 with
    | None -> ignore_expr ?ign e
    | Some f ->
      ignore_expr ?ign @@
      enc_apply ~loc "obj1" [enc_apply ~loc "req" [ estring ~loc f; e ] ]

and core_opt ?option ?camel ?snake ?is_mu ~wrap c =
  let {co_exclude; co_merge; _} = core_attrs c.ptyp_attributes in
  match co_exclude with
  | Some e -> `Exclude e
  | None -> `Include (core ?option ?camel ?snake ?is_mu ~wrap c, co_merge)

and constr ~loc ?(opt=false) ?(assoc=false) ?option ?camel ?snake ?set ?map ?is_mu ~wrap s l =
  match s, l with
  | "int", _ | "Int.t", _ -> enc_var ~loc "int"
  | "int32", _ | "Int32.t", _ -> enc_var ~loc "int32"
  | "int64", _ | "Int64.t", _ -> enc_var ~loc "int53"
  | "float", _ | "Float.t", _ -> enc_var ~loc "float"
  | "bool", _ | "Bool.t", _ -> enc_var ~loc "bool"
  | "string", _ | "String.t", _ -> enc_var ~loc "string"
  | "bytes", _ | "Bytes.t", _ -> enc_var ~loc "bytes"
  | "list", [{ptyp_desc=Ptyp_tuple [{ptyp_desc=Ptyp_constr ({txt;_}, []); _}; c]; _}]
    when assoc && Longident.name txt = "string" ->
    let e = core ?option ?camel ?snake ?is_mu ~wrap c in
    enc_apply ~loc "assoc" [e]
  | "list", [c] | "List.t", [c] ->
    let e = core ?option ?camel ?snake ?is_mu ~wrap c in
    enc_apply ~loc "list" [e]
  | "array", [c] | "Array.t", [c] ->
    let e = core ?option ?camel ?snake ?is_mu ~wrap c in
    enc_apply ~loc "array" [e]
  | "option", [c] | "Option.t", [c] ->
    let e = core ?option ?camel ?snake ?is_mu ~wrap c in
    if opt then e else enc_apply ~loc "option" [e]
  | "Json_repr.ezjsonm", _ | "ezjsonm", _ | "Ezjsonm.value", _ ->
    enc_var ~loc "any_ezjson_value"
  | "Json_repr.any", _ -> enc_var ~loc "any_value"
  | "unit", _ -> enc_var ~loc "empty"
  | "result", [ok; err] | "Result.t", [ok; err] ->
    let ok = core ?option ?camel ?snake ?is_mu ~wrap ok in
    let err = core ?option ?camel ?snake ?is_mu ~wrap err in
    result_expr ok err
  | "Lazy.t", [c] ->
    let e = core ?option ?camel ?snake ?is_mu ~wrap c in
    conv1 ~loc
      (fun e -> eapply ~loc (evar ~loc "Lazy.force") [e])
      (fun e -> eapply ~loc (evar ~loc "Lazy.from_val") [e])
      e
  | "char", _ | "Char.t", _ ->
    conv1 ~loc
      (fun e -> eapply ~loc (evar ~loc "String.make") [eint ~loc 1; e])
      (fun e -> eapply ~loc (evar ~loc "String.get") [e; eint ~loc 0])
      (enc_var ~loc "string")
  | "ref", [c] ->
    let e = core ?option ?camel ?snake ?is_mu ~wrap c in
    conv1 ~loc
      (fun e -> pexp_field ~loc e (llid ~loc "contents"))
      (fun e -> eapply ~loc (evar ~loc "ref") [e])
      e
  | s, [] when SSet.mem s !unit_rec_encoding ->
    eapply ~loc (evar ~loc (enc_name s)) [ eunit ~loc ]
  | _ -> match l, set, map with
    | [], Some enc, _ ->
      let set = String.sub s 0 (String.length s - 2) in
      enc_apply ~loc "conv" [
        evar ~loc (set ^ ".elements");
        evar ~loc (set ^ ".of_list");
        enc_apply ~loc "list" [enc] ]
    | [c], _, Some key_enc ->
      let value_enc = core ?option ?camel ?snake ?is_mu ~wrap c in
      let map = String.sub s 0 (String.length s - 2) in
      let enc = match key_enc with
        | None -> enc_apply ~loc "assoc" [value_enc]
        | Some key_enc -> enc_apply ~loc "list" [enc_apply ~loc "tup2" [key_enc; value_enc]] in
      enc_apply ~loc "conv" [
        evar ~loc (map ^ ".bindings");
        pexp_fun (pvar ~loc "l") @@
        eapply ~loc (evar ~loc "List.fold_left") [
          pexp_fun (pvar ~loc "acc") @@
          pexp_fun (ppat_tuple ~loc [pvar ~loc "k"; pvar ~loc "v"]) @@
          eapply ~loc (evar ~loc (map ^ ".add")) [evar ~loc "k"; evar ~loc "v"; evar ~loc "acc"];
          evar ~loc (map ^ ".empty");
          evar ~loc "l"
        ];
        enc
      ]
    | _ ->
      let es = List.map (core ?option ?camel ?snake ?is_mu ~wrap) l in
      eapply ~loc (evar ~loc (enc_name s)) es

and inherit_case_expr ?option ?is_mu ~parent ?cs_title ~wrap c =
  let loc = c.ptyp_loc in
  match c.ptyp_desc with
  | Ptyp_constr (lid, _) ->
    let e = core ?option ?is_mu ~wrap c in
    let construct = pexp_function ~loc [
        case ~lhs:(ppat_alias ~loc (ppat_type ~loc lid) {txt="x"; loc}) ~guard:None
          ~rhs:(esome (evar ~loc "x"));
        case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:(enone ~loc)
      ] in
    let destruct = pexp_fun (pvar ~loc "x") @@
      pexp_coerce ~loc (evar ~loc "x") None parent in
    let case_title = Option.value ~default:(estring ~loc (Longident.name lid.txt)) cs_title in
    let e =
      if wrap then
        enc_apply ~loc "obj1" [
          enc_apply ~loc "req" [estring ~loc (Longident.name lid.txt); e] ]
    else e in
    case_title, (e, construct, destruct)
  | _ -> raise_error ~loc "inherit type is not a constructor"

and row ?option ?rm_prefix ?singleton ?is_mu ~parent ~wrap prf =
  let {cs_kind; cs_assoc; cs_enum; cs_obj1; cs_kind_label; cs_empty; cs_key; cs_title; cs_description; _} =
    constructor_attrs prf.prf_attributes in
  let loc = prf.prf_loc in
  match prf.prf_desc with
  | Rtag ({txt; _}, _, []) ->
    let case_title = Option.value ~default:(estring ~loc txt) cs_title in
    let e, cons, des =
      case_expr ~loc ~kind:(cs_kind, cs_kind_label) ~typ:`Variant ~name:txt
        ?key:cs_key ?rm_prefix ?empty:cs_empty ?singleton None in
    case_title, cs_description, (e, cons, des)
  | Rtag ({txt; _}, _, h :: _) ->
    let case_title = Option.value ~default:(estring ~loc txt) cs_title in
    let e = core ?assoc:cs_assoc ?enum:cs_enum ?obj1:cs_obj1 ?option ?is_mu ~wrap h in
    let e =
      if wrap then
        enc_apply ~loc "obj1" [
          enc_apply ~loc "req" [estring ~loc txt; e] ]
    else e in
    case_title, cs_description,
    case_expr ~loc ~kind:(cs_kind, cs_kind_label) ~typ:`Variant ~name:txt ?key:cs_key ?rm_prefix ?empty:cs_empty ?singleton (Some e)
  | Rinherit c ->
    let title, x = inherit_case_expr ~parent ?is_mu ?cs_title ~wrap c in
    title, cs_description, x

and variant ~loc ?(enum=false) ?option ?rm_prefix ?is_mu ~parent ~wrap l =
  let rm_prefix = match rm_prefix with
    | Some (`bool false) -> 0
    | Some (`length n) -> n
    | Some (`prefix s) -> String.length s
    | _ ->
      same_prefix @@ List.map (fun p -> match p.prf_desc with
          | Rtag ({txt; _}, _, _) -> txt | _ -> "") l in
  let aux l =
    let singleton = List.length l = 1 in
    let rows = List.map (row ?option ?is_mu ~rm_prefix ~parent ~singleton ~wrap) l in
    enc_apply ~loc "union" [
      elist ~loc @@
      List.map (fun (title, description, (enc, construct, destruct)) ->
          pexp_apply ~loc (evar ~loc (enc_mod "case"))
            [ Labelled "title", title; Optional "description", eoption ~loc description;
              Nolabel, enc; Nolabel, construct; Nolabel, destruct ])
        rows
    ] in
  if enum then
    match List.fold_left (fun acc r ->
        let {cs_key; _} = constructor_attrs r.prf_attributes in
        match acc, r.prf_desc with
        | Some acc, Rtag ({txt; _}, _, []) ->
          let key = match cs_key with Some k -> k | None -> remove_prefix txt rm_prefix in
          Some ((pexp_tuple ~loc [ estring ~loc key; pexp_variant ~loc txt None ]) :: acc)
        | _ -> None) (Some []) l with
    | None -> aux l
    | Some l ->
      enc_apply ~loc "string_enum" [
        elist ~loc (List.rev l) ]
  else aux l

and tuple ~loc ?(obj=false) ?option ?camel ?snake ?is_mu ~wrap l =
  let l =
    if obj then List.mapi (fun i c -> field ~name:(string_of_int i) ?option ?camel ?snake ?is_mu ~wrap c) l
    else List.map (core_opt ?option ?is_mu ~wrap) l in
  let esf = List.filter_map (function `Exclude _ -> None | `Include e -> Some e) l in
  if List.for_all (function `Exclude _ -> false | _ -> true) l then
    obj_expr ~loc ~kind:(if obj then "obj" else "tup") esf
  else
    let pat_to = ppat_tuple ~loc (List.mapi (fun i -> function
        | `Exclude _ -> ppat_any ~loc
        | `Include _ -> pvar ~loc ("t" ^ string_of_int i)) l) in
    let _, rev = List.fold_left (fun (i, acc) -> function
        | `Exclude _ -> i+1, acc
        | `Include _ -> i+1, ("t" ^ string_of_int i) :: acc) (0, []) l in
    let s = List.rev rev in
    let exp_of = pexp_tuple ~loc (List.mapi (fun i -> function
        | `Exclude e -> e
        | `Include _ -> evar ~loc ("t" ^ string_of_int i)) l) in
    enc_apply ~loc "conv" [
      pexp_fun pat_to (pexp_tuple ~loc (List.map (evar ~loc) s));
      pexp_fun (ppat_tuple ~loc (List.map (pvar ~loc) s)) exp_of;
      obj_expr ~loc ~kind:(if obj then "obj" else "tup") esf;
    ]

and field ?attrs ~name ?option ?camel ?snake ?is_mu ~wrap c =
  let loc = c.ptyp_loc in
  let attrs = match attrs with None -> c.ptyp_attributes | Some a -> a in
  let opt = match c.ptyp_desc with
    | Ptyp_constr ({txt; _}, _) when Longident.name txt = "option" || Longident.name txt = "Option.t"
      -> true
    | _ -> false in
  let {fa_field=(field, opt, dft); fa_key; fa_title; fa_description; fa_assoc;
       fa_enum; fa_exclude; fa_obj; fa_enc; fa_obj1; fa_merge; fa_construct_default;
       fa_set; fa_map} =
    field_attrs ~key:name ~opt ?option ?camel ?snake attrs in
  match fa_exclude with
  | None ->
    let enc = core ~opt ?assoc:fa_assoc ?enum:fa_enum ?obj:fa_obj
        ?enc:fa_enc ?obj1:fa_obj1 ?option ?set:fa_set ?map:fa_map ?is_mu ~wrap c in
    if fa_merge then `Include (enc, true)
    else
      let title = match fa_title with None -> [] | Some t -> [Labelled "title", t] in
      let description = match fa_description with None -> [] | Some d -> [Labelled "description", d] in
      let construct = if fa_construct_default then [Labelled "construct", ebool ~loc true] else [] in
      let dft = match dft with None -> [] | Some e -> [Nolabel, e] in
      let f = pexp_apply ~loc (evar ~loc (enc_mod field)) (
          construct @ title @ description @
          [ Nolabel, estring ~loc fa_key; Nolabel, enc ] @ dft) in
      `Include (f, false)
  | Some e -> `Exclude e

and object_expr ~loc ?option ?ign ?camel ?snake ?is_mu ~wrap l =
  let inhs, fields, field_types = List.fold_left (fun (inhs, fields, ft) pof ->
      let attrs = pof.pof_attributes in
      match pof.pof_desc with
      | Oinherit {ptyp_desc = Ptyp_constr ({txt; _}, []); _} -> txt :: inhs, fields, ft
      | Oinherit _ -> inhs, fields, ft
      | Otag ({txt; _}, c) ->
        inhs, (txt, field ~attrs ~name:txt ?option ?camel ?snake ?is_mu ~wrap c) :: fields,
        pof :: ft) ([], [], []) l in
  let inhs, fields, field_types = List.rev inhs, List.rev fields, List.rev field_types in
  let encs = List.filter_map (fun (n, e) -> match e with `Include e -> Some (n, e) | _ -> None) fields in
  let names, encs = List.split encs in
  let construct_fields =
    pexp_fun (pvar ~loc "x") @@
    pexp_tuple ~loc (List.map (fun txt -> pexp_send ~loc (evar ~loc "x") {txt; loc}) names) in
  let destruct_fields =
    pexp_fun (ppat_tuple ~loc (List.map (pvar ~loc) names)) @@
    pexp_object ~loc @@
    class_structure ~self:(ppat_any ~loc)
      ~fields:(List.map (fun (txt, e) -> match e with
          | `Include _e -> pcf_method ~loc ({txt;loc}, Public, Cfk_concrete (Fresh, evar ~loc txt))
          | `Exclude e -> pcf_method ~loc ({txt;loc}, Public, Cfk_concrete (Fresh, e))) fields) in
  let e_fields = enc_apply ~loc "conv" [ construct_fields; destruct_fields; obj_expr ~loc encs ] in
  if inhs = [] then ignore_expr ?ign e_fields
  else
    let var_construct ~loc:_ v = v ~loc in
    let fields_type = ptyp_object ~loc field_types Closed in
    let es_construct_list = List.map (fun txt ->
        (fun ~loc -> pexp_coerce ~loc (evar ~loc "x") None (ptyp_constr ~loc {txt; loc} []))) inhs in
    let es_construct_list =
      if fields <> [] then
        (fun ~loc -> pexp_coerce ~loc (evar ~loc "x") None fields_type) :: es_construct_list
      else es_construct_list in
    let es_encoding = List.map (fun lid -> evar ~loc (enc_name @@ Longident.name lid), true) inhs in
    let es_encoding =
      if fields <> [] then (e_fields, true) :: es_encoding
      else es_encoding in
    let e = enc_apply ~loc "conv" [
        pexp_fun (pvar ~loc "x") (encaps_tuple ~loc var_construct pexp_tuple es_construct_list);
        pexp_fun (ppat_any ~loc) (eapply ~loc (evar ~loc "failwith") [ estring ~loc "cannot destruct inherited types" ]);
        encaps_merge ~loc es_encoding
      ] in
    ignore_expr ?ign {e with pexp_attributes = [
        attribute ~loc ~name:{txt="alert"; loc} ~payload:(PStr [
            pstr_eval ~loc (eapply ~loc (evar ~loc "unsafe") [estring ~loc "inherited types cannot be destructed"]) [] ])
      ]}

let record_label ?(rm_prefix=0) ?option ?camel ?snake ?is_mu ~wrap pld =
  let name = remove_prefix pld.pld_name.txt rm_prefix in
  let e = field ~attrs:pld.pld_attributes ~name ?option ?camel ?snake ?is_mu ~wrap pld.pld_type in
  (pld.pld_name.txt, e)

let record ?local ?ign ?rm_prefix ?option ?camel ?snake ?is_mu ~loc ~wrap l =
  let rm_prefix = match rm_prefix with
    | Some (`bool false) -> 0
    | Some (`length n) -> n
    | Some (`prefix s) -> String.length s
    | _ -> same_prefix @@ List.map (fun pld -> pld.pld_name.txt) l in
  let l = List.map (record_label ~rm_prefix ?option ?camel ?snake ?is_mu ~wrap) l in
  let encs = List.filter_map (fun (_, e) -> match e with `Include e -> Some e | _ -> None) l in
  let lhs_to = ppat_record ~loc (List.map (fun (n, e) ->
      llid ~loc n,
      match e with `Include _ -> pvar ~loc n | `Exclude _ -> ppat_any ~loc) l) Closed in
  let rhs_to = pexp_tuple ~loc (List.filter_map (fun (n, e) -> match e with
      | `Include _ -> Some (evar ~loc n)
      | `Exclude _ -> None) l) in
  let pat_of = ppat_tuple ~loc (List.filter_map (fun (n, e) ->
      match e with `Include _ -> Some (pvar ~loc n) | `Exclude _ -> None) l) in
  let exp_of = pexp_record ~loc (List.map (fun (n, e) ->
      llid ~loc n,
      match e with `Include _ -> evar ~loc n | `Exclude e -> e) l) None in
  let construct, destruct = match local with
    | None ->
      pexp_fun lhs_to rhs_to,
      pexp_fun pat_of exp_of
    | Some cname ->
      pexp_function ~loc [
        case ~guard:None
          ~lhs:(ppat_construct ~loc (llid ~loc cname) (Some lhs_to))
          ~rhs:rhs_to;
        case ~guard:None ~lhs:(ppat_any ~loc)
          ~rhs:(eapply ~loc (evar ~loc "failwith") [ estring ~loc "wrong local record" ])
      ],
      pexp_fun pat_of
        (pexp_construct ~loc (llid ~loc cname) @@ (Some exp_of))
  in
  let e = enc_apply ~loc "conv" [ construct; destruct; obj_expr ~loc encs ] in
  ignore_expr ?ign e

let constructor_label ?option ?rm_prefix ?camel ?snake ?singleton ?is_mu ~wrap pcd =
  let cname = pcd.pcd_name.txt in
  let loc = pcd.pcd_loc in
  let {cs_kind; cs_assoc; cs_enum; cs_obj; cs_enc; cs_title; cs_description;
       cs_ignore; cs_rm_prefix; cs_obj1; cs_kind_label; cs_empty; _} =
    constructor_attrs pcd.pcd_attributes in
  (* let local = match pcd.pcd_res with None -> None | Some _ -> Some cname in *)
  let enc, is_record, is_tuple = match pcd.pcd_args with
    | Pcstr_tuple [] -> None, pcd.pcd_res <> None, None
    | Pcstr_tuple [c] ->
      Some (core ?assoc:cs_assoc  ?enum:cs_enum ?obj:cs_obj ?enc:cs_enc
              ?obj1:cs_obj1 ?option ?camel ?snake ?is_mu ~wrap (* ?local *) c),
      (* pcd.pcd_res <> None *) false, None
    | Pcstr_tuple l ->
      Some (core ?obj:cs_obj ?enc:cs_enc ?option ?camel ?snake ?is_mu ~wrap (ptyp_tuple ~loc l)),
      (* pcd.pcd_res <> None *) false, Some (List.length l)
    | Pcstr_record l ->
      Some (record ~local:cname ~loc ~ign:cs_ignore ~rm_prefix:cs_rm_prefix
              ?option ?camel ?snake ?is_mu ~wrap l), true, None in
  let enc, to_, of_ =
    case_expr ~loc ~is_record ~kind:(cs_kind, cs_kind_label)
      ~typ:`Cons ~name:cname ?rm_prefix ?empty:cs_empty ?singleton ?is_tuple enc in
  let enc =
    if wrap then
      enc_apply ~loc "obj1" [
        enc_apply ~loc "req" [estring ~loc (String.uncapitalize_ascii cname); enc] ]
    else enc in
  Option.value ~default:(estring ~loc (String.uncapitalize_ascii cname)) cs_title, cs_description,
  (enc, to_, of_)

let all_uppercase l =
  List.for_all (fun pcd ->
      pcd.pcd_name.txt = String.uppercase_ascii pcd.pcd_name.txt) l

let constructor ~loc ?(enum=false) ?option ?rm_prefix ?camel ?snake ?is_mu ~wrap l =
  let rm_prefix = match rm_prefix with
    | Some (`bool false) -> 0
    | Some (`length n) -> n
    | Some (`prefix s) -> String.length s
    | _ -> same_prefix @@ List.map (fun pcd -> pcd.pcd_name.txt) l in
  let aux l =
    let singleton = List.length l = 1 in
    let rows = List.map (constructor_label ?option ~rm_prefix ?camel ?snake ~singleton ?is_mu ~wrap) l in
    enc_apply ~loc "union" [
      elist ~loc @@
      List.map (fun (title, description, (enc, to_, of_)) ->
          let loc = enc.pexp_loc in
          pexp_apply ~loc (evar ~loc (enc_mod "case"))
            [ Labelled "title", title; Optional "description", eoption ~loc description;
              Nolabel, enc; Nolabel, to_; Nolabel, of_ ]) rows
    ] in
  if enum then
    let all_uppercase = all_uppercase l in
    match List.fold_left (fun acc pcd ->
        let {cs_key; _} = constructor_attrs pcd.pcd_attributes in
        match acc, pcd.pcd_args with
        | Some acc, Pcstr_tuple [] ->
          let key = match cs_key with
            | Some k -> k
            | None ->
              let name = remove_prefix pcd.pcd_name.txt rm_prefix in
              if all_uppercase then name
              else String.uncapitalize_ascii name in
          Some ((pexp_tuple ~loc [
              estring ~loc key;
              pexp_construct ~loc (llid ~loc pcd.pcd_name.txt) None ]) :: acc)
        | _ -> None) (Some []) l with
    | None -> aux l
    | Some l ->
      enc_apply ~loc "string_enum" [
        elist ~loc (List.rev l) ]
  else aux l

let expressions ?enum ?ign ?mu ?rm_prefix ?title ?description ?schema ?option
    ?camel ?snake ~wrap t =
  let name = t.ptype_name.txt in
  let loc = t.ptype_loc in
  let is_mu = match mu with Some true -> Some name | _ -> None in
  let e = match t.ptype_kind, t.ptype_manifest with
    | Ptype_abstract, None -> raise_error ~loc "abstract type"
    | Ptype_open, _ -> raise_error ~loc "open type"
    | Ptype_abstract, Some m ->
      debug ~v:2 "\tfrom manifest";
      core ?option ?ign ?camel ?snake ?is_mu ~wrap m
    | Ptype_variant l, _ ->
      debug ~v:2 "\tfrom variant";
      constructor ~loc ?enum ?option ?camel ?snake ?is_mu ~wrap l
    | Ptype_record l, _ ->
      debug ~v:2 "\tfrom record";
      record ~loc ?ign ?rm_prefix ?option ?camel ?snake ?is_mu ~wrap l in
  let e = def_expr ?title ?description ?schema ~name:t.ptype_name.txt e in
  mu_expr ?mu ~name e