Source file encoding.ml

open Ppxlib
open Ast_builder.Default
open Utils

module SSet = Set.Make(String)

type result_expressions = {
  enc: expression;
  assoc: expression option;
  type_ext: expression option;
}

let unit_rec_encoding = ref SSet.empty

let case_expr ~loc ?(is_record=false) ?is_tuple ~kind ?(typ=`cons) ~transform ~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 = transform @@ 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, _) -> [%expr Some [%e econstruct ~loc (Some v)] ]
    | true, Some v, (Some _, _) -> [%expr Some ((), [%e econstruct ~loc (Some v)]) ]
    | _, None, _ -> [%expr Some ()]
    | _, Some v, (None, _) -> [%expr Some [%e v] ]
    | _, Some v, (Some _, _) -> [%expr Some ((), [%e 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:[%pat? _] ~rhs:[%expr None]
      ]
    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 _, _) -> [%pat? ((), [%p pconstruct ~loc (Some vp)])])
          ~rhs:(econstruct ~loc (Some ve));
        case ~guard:None
          ~lhs:[%pat? _]
          ~rhs:[%expr failwith "wrong local record"]
      ]
    | _, None, _, _ | _, _, None, _ -> [%expr fun () -> [%e econstruct ~loc None]]
    | _, Some ve, Some vp, (None, _) -> pexp_fun vp (econstruct ~loc (Some ve))
    | _, Some ve, Some vp, (Some _, _) ->
      [%expr fun ((), [%p vp]) -> [%e econstruct ~loc (Some ve)]] in
  enc, construct, destruct

let enum_expr ~loc ?name ?case ?(typ=`cons) ~rm_prefix l  =
  match List.fold_left (fun acc (name, args, attrs) ->
    let {cs_transform; _} = constructor_attrs ?case ~typ attrs in
    match acc, args with
    | Some (acc, other), Some [] ->
      let key = cs_transform @@ remove_prefix name rm_prefix in
      let cons, pat = match typ with
        | `cons -> pexp_construct ~loc (llid ~loc name) None, ppat_construct ~loc (llid ~loc name) None
        | `variant -> pexp_variant ~loc name None, ppat_variant ~loc name None in
      Some ((pexp_tuple ~loc [ estring ~loc key; cons ], pat) :: acc, other)
    | Some (acc, None), Some [ {ptyp_desc=Ptyp_constr ({txt=(Lident "string" | Ldot (Lident "String", "t")); _}, _); _} ] ->
      Some (acc, Some name)
    | _ -> None) (Some ([], None)) l with
  | None -> None
  | Some (l, other) ->
    let exprs, pats = List.split (List.rev l) in
    let assoc = elist ~loc exprs in
    let e, assoc = match name with
      | None -> enc_apply ~loc "string_enum" [ assoc ], None
      | Some name ->
        enc_apply ~loc "string_enum" [ evar ~loc (name ^ "_assoc") ], Some assoc in
    match other with
    | None -> Some (e, assoc)
    | Some cons ->
      let enc, cons, des = case_expr ~loc ~name:cons ~kind:(None, None) ~transform:Fun.id ~typ @@
        Option.some @@ evar ~loc (enc_mod "string") in
      let other_case = enc_apply ~loc "case" [ enc; cons; des ] in
      let rec aux = function
        | [] -> raise_error ~loc "string enum without constant constructor"
        | [ p ] -> p
        | h :: tl -> ppat_or ~loc h (aux tl) in
      let enum_proj = pexp_function ~loc [
        Ast_builder.Default.case ~guard:None ~lhs:(ppat_alias ~loc (aux pats) {loc; txt="_x"}) ~rhs:[%expr Some _x];
        Ast_builder.Default.case ~guard:None ~lhs:[%pat? _] ~rhs:[%expr None]
      ] in
      let enum_case = enc_apply ~loc "case" [ e; enum_proj; [%expr Fun.id] ] in
      Some (enc_apply ~loc "union" [ elist ~loc @@ [ enum_case; other_case ] ], assoc)

let def_expr ?def ?title ?description ?schema ~name e =
  let loc = e.pexp_loc in
  let describe e =
    let title = eoption ~loc title in
    let description = eoption ~loc description in
    enc_apply0 ~loc "def" [
      Nolabel, estring ~loc (Option.value ~default:name def);
      Optional "title", title;
      Optional "description", description;
      Nolabel, e ] in
  let add_schema e schema =
    enc_apply0 ~loc "conv" [
      Nolabel, [%expr Fun.id];
      Nolabel, [%expr Fun.id];
      Labelled "schema", schema;
      Nolabel, e ] in
  match def, title, description, schema with
  | None, None, None , None -> e
  | None, 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" [
      [%expr fun x -> (x, ())]; [%expr fst];
      enc_apply ~loc "merge_objs" [e; enc_var ~loc "unit"]
    ]

let merge_opt_expr ~loc e =
  enc_apply ~loc "union" [ elist ~loc [
    enc_apply ~loc "case" [ e; [%expr Fun.id]; [%expr Option.some] ];
    enc_apply ~loc "case" [
      enc_var ~loc "unit";
      pexp_function ~loc [
        case ~guard:None ~lhs:[%pat? None] ~rhs:[%expr Some ()];
        case ~guard:None ~lhs:[%pat? Some _] ~rhs:[%expr None]
      ];
      [%expr fun () -> None]
    ] ] ]

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;
      [%expr fun [%p pvar ~loc (enc_name name)] -> [%e e]] ]

let result_expr ok err =
  let loc = ok.pexp_loc in
  let ok = enc_apply ~loc "case" [
    ok;
    pexp_function ~loc [
      case ~guard:None ~lhs:[%pat? Ok x] ~rhs:[%expr Some x];
      case ~guard:None ~lhs:[%pat? _] ~rhs:[%expr None] ];
    [%expr Result.ok]
  ] in
  let loc = err.pexp_loc in
  let err = enc_apply ~loc "case" [
    enc_apply ~loc "obj1" [ enc_apply ~loc "req" [estring ~loc "error"; err] ];
    pexp_function ~loc [
        case ~guard:None ~lhs:[%pat? Error e] ~rhs:[%expr Some e];
        case ~guard:None ~lhs:[%pat? _] ~rhs:[%expr None] ];
    [%expr Result.error]
    ] in
  enc_apply ~loc "union" [ elist ~loc [ ok; err ] ]

let resolve_case ~loc = function
  | `separate (title, description, (enc, construct, destruct)) ->
    enc_apply0 ~loc "case"
      [ Labelled "title", title; Optional "description", eoption ~loc description;
        Nolabel, enc; Nolabel, construct; Nolabel, destruct ]
  | `case c -> c

let rec core ?opt ?assoc ?enum ?obj ?enc ?obj1 ?option ?ign ?case ?set ?map ?is_mu ?wrap ?kind ?schema 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;
       co_opt; co_schema; _} =
    core_attrs ?assoc ?enum ?obj ?enc ?obj1 ?set ?map ?schema c.ptyp_attributes in
  match co_enc with
  | Some e -> e
  | None ->
    let opt = match opt, co_opt with Some b, _ -> Some b | _, Some None -> Some true | _ -> None in
    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=(Lident "list" | Ldot (Lident "List", "t")); _}, [{ptyp_desc=Ptyp_variant (l, _, _); ptyp_attributes; _}]) when co_assoc=Some true ->
        assoc_variant ~loc ?option ?case ?is_mu ?wrap ~attrs:ptyp_attributes l
      | 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 ?case ?is_mu ?wrap l
      | Ptyp_variant (l, _, _) ->
        fst @@ variant ~loc ?enum:co_enum ?option ?rm_prefix:co_rm_prefix ~parent:c ?is_mu ?wrap ?kind ?case l
      | Ptyp_object (l, _) -> object_expr ~loc ?option ?case ?is_mu ?wrap l
      | _ -> raise_error ~loc "not handled" in
    let e = match co_schema with None -> e | Some f -> f e in
    match co_obj1 with
    | None -> ignore_expr ?ign e
    | Some f ->
      let o, dft = match co_opt with None -> "req", [] | Some None -> "opt", [] | Some Some e -> "dft", [ e ] in
      ignore_expr ?ign @@
      enc_apply ~loc "obj1" [enc_apply ~loc o ([ estring ~loc f; e ] @ dft) ]

and core_opt ?option ?case ?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 ?case ?is_mu ?wrap c, co_merge)

and core_enum_assoc ?option ?case ?is_mu ?wrap ?kind ~parent ~name l =
  let loc = parent.ptyp_loc in
  let {co_enc; co_rm_prefix ; _} = core_attrs parent.ptyp_attributes in
  match co_enc with
  | Some e -> e, None
  | None -> variant ~loc ~enum:true ?option ?rm_prefix:co_rm_prefix ?is_mu ?wrap ?kind ?case ~parent ~name l

and constr ~loc ?(opt=false) ?(assoc=false) ?option ?case ?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 ?case ?is_mu ?wrap c in
    enc_apply ~loc "assoc" [e]
  | "list", [c] | "List.t", [c] ->
    let e = core ?option ?case ?is_mu ?wrap c in
    enc_apply ~loc "list" [e]
  | "array", [c] | "Array.t", [c] ->
    let e = core ?option ?case ?is_mu ?wrap c in
    enc_apply ~loc "array" [e]
  | "option", [c] | "Option.t", [c] ->
    let e = core ?option ?case ?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 ?case ?is_mu ?wrap ok in
    let err = core ?option ?case ?is_mu ?wrap err in
    result_expr ok err
  | "Lazy.t", [c] ->
    let e = core ?option ?case ?is_mu ?wrap c in
    enc_apply ~loc "conv" [ [%expr Lazy.force]; [%expr Lazy.from_val]; e ]
  | "char", _ | "Char.t", _ ->
    enc_apply ~loc "conv" [
      [%expr String.make 1]; [%expr fun s -> String.get s 0];
      enc_var ~loc "string" ]
  | "ref", [c] ->
    let e = core ?option ?case ?is_mu ?wrap c in
    enc_apply ~loc "conv" [[%expr (!)]; [%expr ref]; e]
  | s, [] when SSet.mem s !unit_rec_encoding ->
    eapply ~loc (evar ~loc (enc_name s)) [ [%expr ()] ]
  | _ -> 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 ?case ?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");
        [%expr fun l -> List.fold_left (fun acc (k, v) ->
          [%e eapply ~loc (evar ~loc (map ^ ".add")) [[%expr k]; [%expr v]; [%expr acc]]])
          [%e evar ~loc (map ^ ".empty")]
          l];
        enc
      ]
    | _ ->
      let es = List.map (core ?option ?case ?is_mu ?wrap) l in
      eapply ~loc (evar ~loc (enc_name s)) es

and inherit_case_expr ?option ?is_mu ~parent ?cs_title ?(wrap=false) 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:[%expr Some x];
      case ~lhs:[%pat? _] ~guard:None ~rhs:[%expr None]
    ] in
    let destruct = [%expr fun x -> (x :> [%t 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=0) ?singleton ?is_mu ~parent ?(wrap=false) ?case ?kind prf =
  let {cs_kind; cs_assoc; cs_enum; cs_obj1; cs_kind_label; cs_empty;
       cs_transform; cs_title; cs_description; cs_case; _} =
    constructor_attrs ~typ:`variant ?kind ?case prf.prf_attributes in
  match cs_case with
  | Some c -> `case c
  | None ->
    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
          ~rm_prefix ?empty:cs_empty ?singleton ~transform:cs_transform None in
      `separate (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 (cs_transform @@ remove_prefix txt rm_prefix); e] ]
        else e in
      `separate (
        case_title, cs_description,
        case_expr ~loc ~kind:(cs_kind, cs_kind_label) ~typ:`variant ~name:txt ~transform:cs_transform
          ~rm_prefix ?empty:cs_empty ?singleton (Some e))
    | Rinherit c ->
      let title, x = inherit_case_expr ~parent ?is_mu ?cs_title ~wrap c in
      `separate (title, cs_description, x)

and variant ~loc ?(enum=true) ?option ?rm_prefix ?is_mu ~parent ?wrap ?case ?kind ?name l =
  let rm_prefix = remove_prefix_options (List.map (fun p -> match p.prf_desc with
    | Rtag ({txt; _}, _, _) -> txt | _ -> "") l) rm_prefix in
  let aux l =
    let singleton = List.length l = 1 in
    let rows = List.map (row ?option ?is_mu ~rm_prefix ~parent ~singleton ?wrap ?case ?kind) l in
    enc_apply ~loc "union" [ elist ~loc @@ List.map (resolve_case ~loc) rows ] in
  if enum && Option.is_none kind && wrap <> Some true then
    match enum_expr ~loc ?case ~typ:`variant ~rm_prefix ?name @@ List.map (fun prf ->
      let name, args = match prf.prf_desc with
        | Rtag ({txt; _}, _, args) -> txt, Some args
        | _ -> "", None in
      name, args, prf.prf_attributes) l
    with
    | None -> aux l, None
    | Some (e, a) -> e, a
  else aux l, None

and assoc_variant ~loc ?option ?is_mu ?wrap ?case ?(attrs=[]) l =
  let {co_rm_prefix; _} = core_attrs attrs in
  let rm_prefix = remove_prefix_options (List.filter_map (fun p -> match p.prf_desc with
    | Rtag ({txt; _}, _, _) -> Some txt | _ -> None) l) co_rm_prefix in
  let l = List.filter_map (fun prf ->
    let {co_obj; _} = core_attrs prf.prf_attributes in
    let loc = prf.prf_loc in
    match prf.prf_desc with
    | Rinherit _ -> None
    | Rtag ({txt; _}, _, l) ->
      let name = remove_prefix txt rm_prefix in
      let enc = match l with
        | [] -> None
        | [ c ] -> Some (core ?option ?is_mu ?wrap ?case c)
        | l -> Some (tuple ~loc ?obj:co_obj ?option ?case ?is_mu ?wrap l) in
      Some (txt, name, enc)
  ) l in
  let schema_properties = List.map (fun (_, name, enc) ->
    let sch = match enc with
      | None -> [%expr Json_schema.(element (Object object_specs))]
      | Some enc -> [%expr Json_schema.root [%e enc_apply ~loc "schema" [ enc ]]] in
    [%expr [%e estring ~loc name], [%e sch], false, None]) l in
  let schema = [%expr Json_schema.(
    create @@ element @@
    Object { object_specs with properties = [%e elist ~loc schema_properties] })] in
  let cons_cases = List.map (fun (txt, name, enc) ->
    Ast_builder.Default.case ~guard:None ~lhs:(ppat_variant ~loc txt (Option.map (fun _ -> pvar ~loc "_c") enc))
      ~rhs:(pexp_tuple ~loc [
        estring ~loc name;
        enc_apply ~loc "construct" [
          Option.value ~default:(enc_var ~loc "empty") enc;
          Option.fold ~none:(eunit ~loc) ~some:(fun _ -> evar ~loc "_c") enc]])
  ) l in
  let cons = [%expr fun _l -> `O (List.map [%e pexp_function ~loc cons_cases] _l)] in
  let des_cases = (
    List.map (fun (txt, name, enc) ->
      Ast_builder.Default.case ~guard:None ~lhs:(pstring ~loc name)
        ~rhs:(pexp_variant ~loc txt
                (Option.map (fun enc -> enc_apply ~loc "destruct" [ enc; evar ~loc "_v" ]) enc))) l) @
    [ Ast_builder.Default.case ~guard:None ~lhs:(pvar ~loc "_s")
        ~rhs:[%expr failwith ("no matching case in assoc variant: " ^ _s)] ] in
  let des = [%expr function
    | `O _l -> List.map (fun (_k, _v) -> [%e pexp_match ~loc (evar ~loc "_k") des_cases]) _l
    | _ -> failwith "assoc variant should be an json object"] in
  pexp_apply ~loc (enc_var ~loc "custom") [
    Labelled "is_object", [%expr true];
    Labelled "schema", schema;
    Nolabel, cons;
    Nolabel, des;
  ]

and tuple ~loc ?(obj=false) ?option ?case ?is_mu ?wrap l =
  let l =
    if obj then List.mapi (fun i c -> field ~name:(string_of_int i) ?option ?case ?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 ?case ?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, opt_c = match c.ptyp_desc with
    | Ptyp_constr ({txt; _}, [ c ]) when Longident.name txt = "option" || Longident.name txt = "Option.t"
      -> true, Some c
    | _ -> false, None 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; fa_schema} =
    field_attrs ~key:name ~opt ?option ?case attrs in
  match fa_exclude with
  | None ->
    begin match fa_merge, opt_c with
      | true, Some c ->
        let enc = core ~opt:false ?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 ?schema:fa_schema c in
        `Include (merge_opt_expr ~loc enc, true)
      | true, _ ->
        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 ?schema:fa_schema c in
        `Include (enc, true)
      | _ ->
        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 ?schema:fa_schema c in
        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 = enc_apply0 ~loc field (
          construct @ title @ description @
          [ Nolabel, estring ~loc fa_key; Nolabel, enc ] @ dft) in
        `Include (f, false)
    end
  | Some e -> `Exclude e

and object_expr ~loc ?option ?ign ?case ?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 ?case ?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 = match l with
    | [] -> pexp_fun (ppat_any ~loc) (eunit ~loc)
    | _ ->
      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 = match l with
    | [] -> pexp_fun (punit ~loc) @@ pexp_object ~loc @@ class_structure ~self:(ppat_any ~loc) ~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 fields_type = ptyp_object ~loc field_types Closed in
  let es_construct_list = List.map (fun txt ->
    (fun ~loc -> [%expr (x :> [%t ptyp_constr ~loc {txt; loc} []])])) inhs in
  let es_construct_list =
    if fields <> [] then
      (fun ~loc -> [%expr (x :> [%t fields_type])]) :: es_construct_list
    else es_construct_list in
  let es_encoding = List.map (fun lid -> evar ~loc (enc_name @@ Longident.name lid)) inhs in
  let es_encoding = if fields <> [] then e_fields :: es_encoding else es_encoding in
  let rec es_construct_tuple = function
    | [] -> assert false
    | [h] -> h ~loc
    | h :: tl -> pexp_tuple ~loc [ h ~loc; es_construct_tuple tl ] in
  let rec es_merge = function
    | [] -> assert false
    | [h] -> h
    | h :: tl -> enc_apply ~loc "merge_objs" [h; es_merge tl] in
  let e = enc_apply ~loc "conv" [
    [%expr fun x -> [%e es_construct_tuple es_construct_list]];
    [%expr fun _ -> failwith "cannot destruct inherited types"];
    es_merge es_encoding
  ] in
  ignore_expr ?ign {e with pexp_attributes = [
    attribute ~loc ~name:{txt="alert"; loc} ~payload:(PStr [%str unsafe "inherited types cannot be destructed"])
  ]}

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

let record ?local ?ign ?rm_prefix ?option ?case:cas ?is_mu ~loc ?wrap l =
  let rm_prefix = remove_prefix_options (List.map (fun pld -> pld.pld_name.txt) l) rm_prefix in
  let l = List.map (record_label ~rm_prefix ?option ?case:cas ?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:[%pat? _]
          ~rhs:[%expr failwith "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=0) ?case ?singleton ?is_mu ?(wrap=false) ?kind ~loc ~name ~attrs args =
  let cname = name 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; cs_transform;
       cs_case; cs_schema; _} =
    constructor_attrs ?case ~typ:`cons ?kind attrs in
  match cs_case with
  | Some e -> `case e
  | None ->
    (* let local = match pcd.pcd_res with None -> None | Some _ -> Some cname in *)
    let enc, is_record, is_tuple = match args with
      | Pcstr_tuple [] -> None, false (* 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 ?case ?is_mu ~wrap ?schema:cs_schema (* ?local *) c),
        (* pcd.pcd_res <> None *) false, None
      | Pcstr_tuple l ->
        Some (core ?obj:cs_obj ?enc:cs_enc ?option ?case ?is_mu ~wrap ?schema:cs_schema (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 ?case ?is_mu ~wrap l), true, None in
    let cs_kind = Option.map cs_transform cs_kind in
    let enc2, 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 ~transform:cs_transform enc in
    let enc = match enc, wrap with
      | Some _, true ->
        let key = cs_transform @@ remove_prefix cname rm_prefix in
        enc_apply ~loc "obj1" [
          enc_apply ~loc "req" [estring ~loc key; enc2] ]
      | _ -> enc2 in
    let cs_title = Option.value ~default:(estring ~loc (cs_transform @@ remove_prefix cname rm_prefix)) cs_title in
    `separate (cs_title, cs_description, (enc, to_, of_))

let constructor ~loc ?(enum=true) ?option ?rm_prefix ?case ?is_mu ?wrap ?name ?kind l =
  let rm_prefix = remove_prefix_options (List.map (fun pcd -> pcd.pcd_name.txt) l) rm_prefix in
  let aux l =
    let singleton = List.length l = 1 in
    let rows = List.map (fun pcd ->
      constructor_label ?option ~rm_prefix ?case ~singleton ?is_mu ?wrap ?kind
        ~loc:pcd.pcd_loc ~name:pcd.pcd_name.txt ~attrs:pcd.pcd_attributes pcd.pcd_args
    ) l in
    enc_apply ~loc "union" [ elist ~loc @@ List.map (resolve_case ~loc) rows ] in
  if enum && Option.is_none kind && wrap <> Some true then
    match enum_expr ~loc ?name ?case ~rm_prefix @@ List.map (fun pcd ->
      let args = match pcd.pcd_args with Pcstr_tuple l -> Some l | _ -> None in
      pcd.pcd_name.txt, args, pcd.pcd_attributes) l with
    | None -> aux l, None
    | Some (e, assoc) -> e, assoc
  else aux l, None

let expressions ?enum ?ign ?mu ?rm_prefix ?title ?description ?schema ?option
    ?case ?wrap ?(assoc=false) ?kind ?def 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 r = match t.ptype_kind, t.ptype_manifest with
    | Ptype_abstract, None -> raise_error ~loc "abstract type"
    | Ptype_open, _ ->
      let type_ext = Some [%expr ref []] in
      let enc = pexp_lazy ~loc @@
        enc_apply ~loc "union" [ [%expr ![%e evar ~loc ("_" ^ name ^ "_ext_cases")]] ] in
      { enc; assoc=None; type_ext }
    | Ptype_abstract, Some ({ ptyp_desc=Ptyp_variant (l, _, _); _} as parent) when assoc ->
      let enc, assoc = core_enum_assoc ?option ?case ?is_mu ?kind ?wrap ~parent ~name l in
      { enc; assoc; type_ext=None }
    | Ptype_abstract, Some m ->
      { enc=core ?option ?ign ?case ?is_mu ?kind ?wrap ~assoc m; assoc=None; type_ext=None }
    | Ptype_variant l, _ ->
      let name = if assoc then Some name else None in
      let enc, assoc = constructor ~loc ?enum ?rm_prefix ?option ?case ?is_mu ?wrap ?name ?kind l in
      { enc; assoc; type_ext=None }
    | Ptype_record l, _ ->
      { enc=record ~loc ?ign ?rm_prefix ?option ?case ?is_mu ?wrap l; assoc=None; type_ext=None } in
  let enc = def_expr ?def ?title ?description ?schema ~name:t.ptype_name.txt r.enc in
  { r with enc = mu_expr ?mu ~name enc }

let choose_case ?(camel=false) ?(snake=false) ?(pascal=false) ?(kebab=false)
    ?(upper=false) ?(cap=false) ?(lower=false) () =
  match camel, snake, pascal, kebab, upper, lower, cap with
  | true, _,  _, _, _, _, _ -> Some `camel
  | _, true, _, _, _, _, _ -> Some `snake
  | _, _, true, _, _, _, _ -> Some `pascal
  | _, _, _, true, _, _, _ -> Some `kebab
  | _, _, _, _, true, _, _ -> Some `upper
  | _, _, _, _, _, true, _ -> Some `lower
  | _, _, _, _, _, _, true -> Some `cap
  | _ -> None

let structure ~loc ?(enum=true) ?(ign=false) ?(mu=false) ?(force_debug=false)
    ?rm_prefix ?option ?title ?description ?schema ?name ?modu ?wrap
    ?camel ?snake ?pascal ?kebab ?upper ?lower ?cap ?(assoc=false) ?kind ?def
    ~rec_flag l =
  if fake then [] else
  let () = Utils.wrap modu in
  List.iter (fun t ->
    if List.length l >= 2 && List.length t.ptype_params = 0 then
      unit_rec_encoding := SSet.add t.ptype_name.txt !unit_rec_encoding) l;
  let case = choose_case ?camel ?snake ?pascal ?kebab ?upper ?lower ?cap () in
  let l, assoc, type_ext = List.fold_left (fun (acc, acc_assoc, acc_type_ext) t ->
    let r = expressions ~enum ~ign ~mu ?case ?rm_prefix
        ?option ?title ?description ?schema ?wrap ~assoc ?kind ?def t in
    let enc_name = match name with
      | None -> enc_name ~search:false t.ptype_name.txt
      | Some n -> add_enc_name t.ptype_name.txt n; n in
    let params = List.map fst t.ptype_params in
    let expr = add_params_fun r.enc params in
    let typ =
      ptyp_constr ~loc (llid ~loc @@ enc_mod "encoding") [
        ptyp_constr ~loc (llid ~loc t.ptype_name.txt) params ] in
    let typ = add_params_fun_sig typ params in
    let typ = match r.type_ext with
      | None -> typ
      | Some _ -> [%type: [%t typ] lazy_t] in
    let expr, typ =
      if List.length l >= 2 && List.length params = 0 && rec_flag <> Nonrecursive then
        [%expr fun () -> [%e expr]], [%type: unit -> [%t typ]]
      else expr, typ in
    let acc_assoc = match r.assoc with
      | None -> acc_assoc
      | Some expr -> acc_assoc @ [ value_binding ~loc ~pat:(pvar ~loc (t.ptype_name.txt ^ "_assoc")) ~expr ] in
    let acc_type_ext = match r.type_ext with
      | None -> acc_type_ext
      | Some expr -> acc_type_ext @ [ value_binding ~loc ~pat:(pvar ~loc ("_" ^ t.ptype_name.txt ^ "_ext_cases")) ~expr ] in
    acc @ [ value_binding ~loc ~pat:(ppat_constraint ~loc (pvar ~loc enc_name) typ) ~expr ], acc_assoc, acc_type_ext
  ) ([], [], []) l in
  let rec_flag = if List.length l < 2 then Nonrecursive else rec_flag in
  let s =
    (match assoc with [] -> [] | l -> [ pstr_value ~loc Nonrecursive l ]) @
    (match type_ext with [] -> [] | l -> [ pstr_value ~loc Nonrecursive l ]) @
    [ pstr_value ~loc rec_flag l ] in
  debug ~force:force_debug "%s\n" (str_of_structure s);
  unwrap ();
  s

let signature ~loc ?name ?modu l =
  if fake then [] else
  let () = Utils.wrap modu in
  let l = List.map (fun t ->
    let name = match name with None -> enc_name ~search:false t.ptype_name.txt | Some n -> n in
    let params = List.map fst t.ptype_params in
    let typ = add_params_fun_sig
        (ptyp_constr ~loc (llid ~loc @@ enc_mod "encoding") [
           ptyp_constr ~loc (llid ~loc t.ptype_name.txt) params ]) params in
    let typ = match t.ptype_kind with
      | Ptype_open -> [%type: [%t typ] lazy_t]
      | _ -> typ in
    value_description ~loc ~name:{txt=name; loc} ~type_:typ ~prim:[]) l in
  let s = List.map (psig_value ~loc) l in
  debug "%s\n" (str_of_signature s);
  unwrap ();
  s

let type_ext_structure ~loc ?(force_debug=false) ?option ?rm_prefix ?(wrap=false) ?kind ?modu
    ?camel ?snake ?pascal ?kebab ?upper ?lower ?cap t =
  if fake then [] else
  let () = Utils.wrap modu in
  let case = choose_case ?camel ?snake ?pascal ?kebab ?upper ?lower ?cap () in
  let rm_prefix = remove_prefix_options (List.map (fun pext -> pext.pext_name.txt) t.ptyext_constructors) rm_prefix in
  let rows = List.filter_map (fun pext ->
    match pext.pext_kind with
    | Pext_decl ([], args, None) ->
      Some (constructor_label ~wrap ?option ~rm_prefix ?case ?kind
              ~loc:pext.pext_loc ~name:pext.pext_name.txt ~attrs:pext.pext_attributes args)
    | _ -> None
  ) t.ptyext_constructors in
  let cases = elist ~loc @@ List.map (resolve_case ~loc) rows in
  let tname = Longident.name t.ptyext_path.txt in
  let cases_name = match String.rindex_opt tname '.' with
    | None -> "_" ^ tname ^ "_ext_cases"
    | Some i -> String.sub tname 0 i ^ "._" ^ String.sub tname (i+1) (String.length tname - i - 1) ^ "_ext_cases" in
  let expr = [%expr
    [%e evar ~loc cases_name] := ! [%e evar ~loc cases_name] @ [%e cases] ] in
  let s = [
    pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:(punit ~loc) ~expr ]
  ] in
  debug ~force:force_debug "%s\n" (str_of_structure s);
  unwrap ();
  s