Source file ppx_meta_conv.ml

open Ppxlib.Ast
open Spotlib.Spot
open Longident
open Asttypes
open Ppxx.Helper

let string_of_core_type = Ppxlib.string_of_core_type

(* poly_a for 'a *)
let poly_var v = "poly_" ^ v

(** <'a -> 'b t> ==>   ( <'a 'b . 'a -> 'b t>, ["poly_a"; "poly_b"], <poly_a -> poly_b t> ) *)
(*
let gadtize ty =
  let open Ast_mapper in
  let vars = ref [] in
  let extend super =
    let typ self cty = match cty.ptyp_desc with
      | Ptyp_var a ->
          let n = poly_var a in
          if not & List.mem a !vars then vars := a :: !vars;
          { cty with ptyp_desc = Ptyp_constr ({ txt= Lident n; loc= cty.ptyp_loc }, []) }
      | _ -> super.typ self cty
    in
    { super with typ }
  in
  let mapper = extend Ast_mapper.default_mapper in
  let ty' = mapper.typ mapper ty in
  Typ.poly (List.map (!@) !vars) ty,
  List.map poly_var !vars,
  ty'
*)

module X = Ppxlib.Ast_traverse

let gadtize ty =
  let vars = ref [] in
  let module M = struct
    class mapper = object
      inherit Ppxlib.Ast_traverse.map as super
      method! core_type cty = match cty.ptyp_desc with
        | Ptyp_var a ->
            let n = poly_var a in
            if not & List.mem a !vars then vars := a :: !vars;
            { cty with ptyp_desc = Ptyp_constr ({ txt= Lident n; loc= cty.ptyp_loc }, []) }
        | _ -> super#core_type cty
    end
  end in
  let mapper = new M.mapper in
  let ty' = mapper#core_type ty in
  Typ.poly (List.map (!@) !vars) ty,
  List.map poly_var !vars,
  ty'

(** let [n] : [ty] = body, but with gadt type thing, i.e.
    let [n] : type a b . ty[a/'a,b/'b] = body
 *)
let vb_newtypes n ty body =
  let poly, vars, ty' = gadtize ty in
  let exp = Exp.constraint_ body ty' in
  let exp = List.fold_right Exp.newtype (List.map (!@) vars) exp in
  Vb.mk (Pat.constraint_ (Pat.var n) poly) exp

(* It seems there is no good way to surpress the warning 39
   of a toplevel let locally via attributes.
   (See http://caml.inria.fr/mantis/view.php?id=6677)

   let rec x = 1
   and y = 2

   let [@ocaml.warning "-39"] rec x = 1        is not valid

   We have a workaround here:

   let (x,y) =
     let [@ocaml.warning "-39"] rec x = 1
     and y = 2
     in
     (x,y)
*)

(** Get <p> of [@conv.<k> <p>] *)
let get_conv_attribute k attrs =
  List.filter_map (fun { attr_name={txt}; attr_payload= p; _ } ->
    match String.is_prefix' "conv." txt with
    | Some s when s = k -> Some p
    | _ -> None) attrs

(** Payload of [@conv.<k>] *)
let parse_conv_payload = function
  | PStr [] -> `None
  | PStr [ { pstr_desc = Pstr_eval (e, _) } ] ->
      let rec parse_payload_expr e = match e.pexp_desc with
        | Pexp_ident {txt = Longident.Lident s} -> `Ident s   (* x *)
        | Pexp_construct ({txt= Longident.Lident s}, None) -> `Constr s (* X.x *)
        | Pexp_constant (Pconst_string (s, _, _)) -> `String s (* "x" *)
        | Pexp_record (fields, None) -> (* { x=e; ..; x=e } *)
            `Record (List.map (function
              | ({txt=Longident.Lident s}, e) -> s, parse_payload_expr e
              | _ -> failwith "[@conv.xxx] payload record cannot be qualified: x is ok, but X.x is not.") fields)
        | _ -> failwith "[@conv.xxx] payload format error"
      in
      parse_payload_expr e
  | _ -> failwith "[@conv.xxx] payload format error"

(** [@conv.as <name>]
    <name> can be an ident/string/constr or records whose keys are modes: { ocaml="..."; sexp="..." }
*)
let conv_as mode default attrs =
  match
    get_conv_attribute "as" attrs
    |> List.map parse_conv_payload
  with
  | [] -> default
  | [(`Ident s | `String s | `Constr s)] -> s
  | [`Record r] ->
      begin match List.assoc_opt mode r with
      | None -> default
      | Some (`Ident s | `String s | `Constr s) -> s
      | _ -> failwith "[@conv.as ...] payload format error"
      end
  | _ -> failwith "Multiple [@conv.as ...] are not allowed"

(** [@conv.ignore_unknown_fields {ocaml; sexp}] *)
let conv_ignore_unknown_fields mode attrs =
  match
    get_conv_attribute "ignore_unknown_fields" attrs
    |> List.map parse_conv_payload
  with
  | [] -> false
  | [`None] -> true
  | [`Record r] ->
      begin match List.assoc_opt mode r with
      | None -> false
      | Some (`Ident s) when mode = s -> true
      | _ -> failwith "[@conv.ignore_unknown_fields ...] payload format error"
      end
  | _ -> failwith "[@conv.ignore_unknown_fields] payload format error"

(** let (x,y,z) = let rec x = .. and y = .. and z = .. in (x,y,z)
    This indirection is required for [@ocaml.warning "-39"].
    Probably this will not be required in future.

    We also do a fix for Warning 32 here
*)
let str_value_maybe_rec vbs =
  let rec the_var_of_pattern p = match p.ppat_desc with
    | Ppat_var sloc -> sloc
    | Ppat_constraint (p,_) -> the_var_of_pattern p
    | _ -> assert false
  in
  let the_var_of_vb vb = the_var_of_pattern vb.pvb_pat in
  let vars = List.map the_var_of_vb vbs in
  Str.value Nonrecursive
    [ Vb.mk (Pat.tuple' & List.map (fun {txt;loc} -> Pat.var' ~loc txt) vars)
        (Exp.let_ Recursive vbs ~attrs:[Attr.ocaml "warning" (Exp.string "-27-39")]

         & Exp.tuple' & List.map (fun {txt;loc} -> Exp.var ~loc txt) vars)
    ]
  :: List.map (fun {txt;loc} ->
      Str.value Nonrecursive [ Vb.mk (Pat.any ()) (Exp.var ~loc txt) ] ) vars

let argn = Printf.sprintf "a%d"

let mangle affix name =
  match affix with
  | `PrefixSuffix (p, s) -> p ^ "_" ^ name ^ "_" ^ s
  | `Prefix x -> x ^ "_" ^ name
  | `Suffix x -> name ^ "_" ^ x

let mangle_lid affix lid =
  match lid with
  | Lident s    -> Lident (mangle affix s)
  | Ldot (p, s) -> Ldot (p, mangle affix s)
  | Lapply _    -> assert false

let mangle_type_decl affix { ptype_name = { txt = name } } =
  mangle affix name

module Make(M : sig
  val deriver : string
  (** ex. conv *)

  val name : string
  (** ex. ocaml *)

  val type_ : string
  (** ex. s *)

  val conv : string
  (** ex. Ocaml_conv *)
end) : sig
  module Encoder: sig
    val str_of_type
          : is_gadt:bool
            -> path:string list
            -> type_declaration
            -> value_binding list

    val sig_of_type
        : path:string list  (* XXX not used! *)
          -> type_declaration
          -> signature_item list

    val expr_of_typ
        : (string * string) list (*+ env from type var names to variables *)
          -> core_type
          -> expression
  end

  module Decoder: sig
    val str_of_type
        : path:string list
          -> type_declaration
          -> value_binding list

    val sig_of_type
        : path:string list  (* XXX not used! *)
          -> type_declaration
          -> signature_item list

    val expr_of_typ : core_type -> expression
    val expr_of_typ_exn : core_type -> expression
  end
end = struct

  (* Ocaml.t *)
  let the_target_type = lid M.type_

  (* Ocaml_conv.s *)
  let conv s = M.conv ^.^ s

  (* Ocaml_conv.s *)
  let econv s = Exp.ident & lid & M.conv ^.^ s

  (** True if [ty] is [<M.type_> mc_leftovers] *)
  let is_for_leftovers ty = match ty with
    | [%type: [%t? typ] mc_leftovers] ->
        begin match typ with
        | { ptyp_desc = Ptyp_constr ({txt}, []) } -> txt = the_target_type.txt
        | _ -> false
        end
    | _ -> false

  (** True if [ty] is [<M.type_> mc_option_embeded] or [<M.type_> mc_embeded] *)
  let is_for_embeded (l, typ, _) =
    match typ with
    | [%type: [%t? typ] mc_option_embeded] ->
        Some (l, `Option_embeded, typ)
    | [%type: [%t? typ] mc_embeded] ->
        Some (l, `Embeded,        typ)
    | _ -> None

  (** True if [ty] is [t mc_option] for some [t] *)
  let is_mc_option ty = match ty with
    | [%type: [%t? typ] mc_option] -> Some typ
    | _ -> None

  module Encoder = struct

    type fields =
      | Field of string * core_type * string
      | OptionField of string * core_type * string
      | Leftovers of string
      | Embeded of core_type * string
      | Option_embeded of core_type * string

    (** conv.ocaml_of *)
    let deriver = M.deriver ^.^ M.name ^ "_of"

    (** ocaml_of_<n> *)
    let of_ n = Exp.ident & lid & M.name ^ "_of_" ^ n

    (** Ocaml_conv.Constr.variant *)
    let constr n = econv & "Constr" ^.^ n

    (** Ocaml_conv.Deconstr.variant *)
    let deconstr n = econv & "Deconstr" ^.^ n

    (** M.ocaml_of_t for M.t *)
    let mangle_lid = mangle_lid (`Prefix (M.name ^ "_of"))

    (** ocaml_of_t for type t *)
    let mangle_type_decl = mangle_type_decl (`Prefix (M.name ^ "_of"))

    let rec expr_of_typ env typ =
      if typ.ptyp_loc == Location.none then assert false;
      (* Location.print_loc and others somehow breaks already printed things *)
      Ast_helper.with_default_loc typ.ptyp_loc & fun () ->
      let loc = typ.ptyp_loc in
      match typ with
      | [%type: int       ]                        -> of_ "int"
      | [%type: int32     ] | [%type: Int32.t]     -> of_ "int32"
      | [%type: int64     ] | [%type: Int64.t]     -> of_ "int64"
      | [%type: nativeint ] | [%type: Nativeint.t] -> of_ "nativeint"
      | [%type: float     ]                        -> of_ "float"
      | [%type: bool      ]                        -> of_ "bool"
      | [%type: char      ]                        -> of_ "char"
      | [%type: string    ]                        -> of_ "string"
      | [%type: bytes     ]                        -> of_ "bytes"
      | [%type: [%t? typ] ref]   ->
          [%expr [%e of_ "ref"] [%e expr_of_typ env  typ] ]
      | [%type: [%t? typ] list]  ->
          [%expr [%e of_ "list"] [%e expr_of_typ env  typ] ]
      | [%type: [%t? typ] array] ->
          [%expr [%e of_ "array"] [%e expr_of_typ env  typ] ]
      | [%type: [%t? typ] option] ->
          [%expr [%e of_ "option"] [%e expr_of_typ env  typ] ]
      | { ptyp_desc = Ptyp_arrow (_l, t1, t2) } ->
          [%expr [%e of_ "arrow"] [%e expr_of_typ env  t1] [%e expr_of_typ env  t2]]
      | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ env  typ
      | { ptyp_desc = Ptyp_var name } ->
          begin match List.assoc_opt name env with
          | Some name' -> [%expr [%e Exp.var name']]
          | None -> [%expr fun _ -> assert false]
          end
      | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } ->
          let args_pp = List.map (fun typ -> [%expr [%e expr_of_typ env  typ]]) args in
          Exp.apply' (Exp.lident (mangle_lid lid)) args_pp
      | { ptyp_desc = Ptyp_tuple typs } ->
          let args = List.mapi (fun i typ -> Exp.apply' (expr_of_typ env  typ) [Exp.var (argn i)]) typs in
          [%expr
              fun [%p Pat.tuple' (List.mapi (fun i _ -> Pat.var' (argn i)) typs)] ->
                [%e constr "tuple"] [%e Exp.list args]
          ]
      | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } ->
          let cases =
            fields |> List.map (fun field ->
              match field.prf_desc, field.prf_attributes with
              | Rtag (label, true (*empty*), []), attrs -> (* `L *)
                  let label' = conv_as M.name label.txt attrs in
                  Exp.case (Pat.variant label.txt None)
                    [%expr
                        [%e constr "poly_variant" ]
                        [%e Exp.string "<poly_var>"]
                        [%e Exp.string label']
                        []
                    ]
              | Rtag (label, false, [typ]), attrs -> (* `L of typ *)
                  let label' = conv_as M.name label.txt attrs in
                  Exp.case (Pat.variant label.txt (Some [%pat? x]))
                    [%expr
                        [%e constr "poly_variant" ]
                        [%e Exp.string "<poly_var>"]
                        [%e Exp.string label']
                        [ [%e expr_of_typ env  typ] x ]
                    ]
              | Rinherit ({ ptyp_desc = Ptyp_constr (tname, []) } as typ), _attrs -> (* [ tname ] *)
                  Exp.case [%pat? [%p Pat.type_ tname] as x]
                    [%expr [%e expr_of_typ env  typ] x]
              | _ ->
                  raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
                      deriver (string_of_core_type typ))
          in
          Exp.function_ cases

      | { ptyp_desc = Ptyp_object (_fields, Open); ptyp_loc } ->
          raise_errorf ~loc:ptyp_loc "%s cannot be derived for open object type %s"
            deriver (string_of_core_type typ)

      | { ptyp_desc = Ptyp_object (ofields, Closed) } ->
          let make_block =
            [%expr
                [%e constr "object_"]
                [%e Exp.string "<object>"]
            ]
          in
          let get name = Exp.send (Exp.var "x") name in
          let make_fields = function
            | Field (name', ty, name) ->
                [%expr [ ([%e Exp.string name'],
                          [%e expr_of_typ env  ty] [%e get !@name ]) ]
                ]
            | OptionField (name', ty, name) ->
                [%expr
                    match [%e get !@name] with
                    | None -> []
                    | Some __v -> [ [%e Exp.string name'],
                                    [%e expr_of_typ env  ty] __v ]
                ]
            | Leftovers name -> get !@name
            | Embeded (ty, name) ->
                [%expr
                    [%e deconstr "object_"]
                    "<object>"
                    ([%e expr_of_typ env  ty] [%e get !@name])
                ]
            | Option_embeded (ty, name) ->
                [%expr
                    match [%e get !@name ] with
                    | None -> []
                    | Some o ->
                        [%e deconstr "object_"]
                          "<object>"
                          ([%e expr_of_typ env  ty] o)
                ]
          in
          let fields =
            List.filter_map (function
                | { pof_desc= Otag ({txt}, ty); pof_attributes=attrs; _} ->
                    Some (txt, ty, attrs)
                | _ -> None) ofields
          in
          [%expr fun x ->
            [%e expr_of_fields ~make_block ~make_fields fields
            ]
          ]

      | { ptyp_loc } ->
          raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
            deriver (string_of_core_type typ)

    and expr_of_fields ~make_block ~make_fields fields =
      let fields =
        fields |> List.map (fun ((name, ty, attrs) as field) ->
            if is_for_leftovers ty then Leftovers name
            else
              match is_for_embeded field with
              | None ->
                  let name' = conv_as M.name name attrs in
                  begin match is_mc_option ty with
                  | None -> Field (name', ty, name)
                  | Some ty -> OptionField (name', ty, name)
                  end
              | Some (_, `Embeded, typ) -> Embeded (typ, name)
              | Some (_, `Option_embeded, typ) -> Option_embeded (typ, name)
        )
      in
      (* <make_block> (List.concat <map make_fields fields>) *)
      let loc = Location.none in (* XXX *)
      [%expr
        (* CR jfuruse: record must check the dups. Does it do already? *)
        [%e make_block] (List.concat [%e Exp.list & List.map make_fields fields])
      ]

    let sig_of_encoder type_decl =
      let typ = Ppx_deriving.core_type_of_type_decl type_decl in
      let enc typ = Typ.constr (lid ~loc:typ.ptyp_loc (conv "encoder")) [typ] in
      let polymorphize = Ppx_deriving.poly_arrow_of_type_decl enc type_decl in
      polymorphize (enc typ)

    let sig_of_type ~path:_ type_decl =
      Ast_helper.with_default_loc type_decl.ptype_loc & fun () ->
      [ Sig.value & Val.mk
          (at (mangle_type_decl type_decl))
          (sig_of_encoder type_decl)
      ]

    (** build [ocaml_of_t], [t_of_ocaml] etc for type [t] *)
    let str_of_type ~is_gadt ~path ({ ptype_loc = loc } as type_decl) =
      Ast_helper.with_default_loc loc & fun () ->
      (* let path = Ppx_deriving.path_of_type_decl ~path type_decl in *)
      let type_name = String.concat "." (path @ [type_decl.ptype_name.txt]) in
      let conv_of =
        let env = List.concat_map (fun (ty, _) ->
          match ty.ptyp_desc with
          | Ptyp_any -> []
          | Ptyp_var v -> [(v, poly_var v)]
          | _ -> assert false) type_decl.ptype_params
        in

        (* has free var [x] *)
        let record (labels : label_declaration list) : expression =
          let make_block =
            (* XXX_conv.Constr.record "<type_name>" *)
            [%expr
                [%e constr "record"]
                [%e Exp.string type_name]
            ]
          in
          let get n =
            (* x.<n> *)
            Exp.field (Exp.var "x") & lid n
          in
          let make_fields = function
            | Field (name', ty, name) ->
                (* [ "<name'>", xxx_of_ty (x.<name>) ] *)
                [%expr [ [%e Exp.string name'],
                         [%e expr_of_typ env ty]
                           [%e get name ] ] ]
            | OptionField (name', ty, name) ->
                (* match x.<name> with
                   | None -> []
                   | Some __v -> [ "<name'>", xxx_of_ty __v ]
                *)
                [%expr
                    match [%e get name ] with
                    | None -> []
                    | Some __v -> [ [%e Exp.string name'],
                                    [%e expr_of_typ env  ty] __v ]
                ]
            | Leftovers name ->
                (* x.<name> *)
                get name
            | Embeded (ty, name) ->
                (* XXX_conv.Deconstr.record "<embeded record>"
                     (xxx_of_ty x.<name>)
                *)
                [%expr
                    [%e deconstr "record"]
                    "<embeded record>" (* XXX must be type name of ty *)
                    ([%e expr_of_typ env  ty]
                        [%e get name ])
                ]
            | Option_embeded (ty, name) ->
                (* match x.<name> with
                   | None -> []
                   | Some o ->
                       XXX_conv.Deconstr.record "<embeded record>"
                         (xxx_of_ty x.<name>)
                *)
                [%expr
                    match [%e get name ] with
                    | None -> []
                    | Some o ->
                        [%expr
                            [%e deconstr "record"]
                            "<embeded record>" (* XXX must be type name of ty *)
                            ([%e expr_of_typ env ty] o)
                        ]
                ]
          in
          expr_of_fields ~make_block ~make_fields
          & List.map (fun pld ->
              (pld.pld_name.txt, pld.pld_type, pld.pld_attributes)) labels
        in
        match type_decl.ptype_kind, type_decl.ptype_manifest with
        | Ptype_abstract, Some manifest ->
            (* XXX Do we really need this eta expansion? *)
            (* fun x -> xxx_of_manifest x *)
            [%expr fun x -> [%e expr_of_typ env  manifest] x]
        | Ptype_variant constrs, _ ->
            let cases =
              constrs |> List.map (fun { pcd_name= { txt= constr_name }
                                       ; pcd_args
                                       ; pcd_attributes= attrs
                                       ; pcd_res } ->
                let env = match pcd_res with
                  | None -> env
                  | Some ( { ptyp_desc= Ptyp_constr (_lidloc, ctys) } ) ->
                      (* It's gadt. [poly_a] can be not for ['a]. *)
                      List.concat_map (function
                        | (({ptyp_desc= Ptyp_var vo},_), {ptyp_desc= Ptyp_var v}) -> [(v, poly_var vo)]
                        | _ -> [] (* CR jfuruse: we cannot do further? *))
                        (List.combine type_decl.ptype_params ctys)
                  | _ -> assert false
                in
                let constr_name' = conv_as M.name constr_name attrs in
                let args = match pcd_args with
                  | Pcstr_tuple ctys ->
                      List.mapi (fun i typ ->
                        (* expr_of_<typ> a<i> *)
                        Exp.apply' (expr_of_typ env typ) [Exp.var (argn i)]) ctys
                  | Pcstr_record lds ->
                      [ record lds ]
                in
                let result =
                  (* Ocaml_conv.Constr.variant "XXX.<type_name>" "<constr_name'>" [<args>] *)
                  [%expr [%e constr "variant"]
                      [%e Exp.string type_name]
                      [%e Exp.string constr_name']
                      [%e Exp.list args]
                  ]
                in
                match pcd_args with
                | Pcstr_tuple ctys ->
                    (* <constr_name>(a0,...,an) -> <result> *)
                    Exp.case (Pat.construct (lid constr_name)
                                (match ctys with
                                 | [] -> None
                                 | ctys ->
                                     Some (Pat.tuple' (List.mapi (fun i _ -> Pat.var' (argn i)) ctys)))) result
                | Pcstr_record _ ->
                    (* <constr_name> x -> {l0=a0;...;ln=a0} *)
                    Exp.case (Pat.construct (lid constr_name) (Some (Pat.var' "x"))) result)
            in
            Exp.function_ cases
        | Ptype_record labels, _ -> [%expr fun x -> [%e record labels]]

        | Ptype_abstract, None ->
            raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver
        | Ptype_open, _        ->
            raise_errorf ~loc "%s cannot be derived for open types" deriver
      in
      let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in
      if is_gadt then
        let ty = sig_of_encoder type_decl in
        [vb_newtypes
           (at ~loc:type_decl.ptype_loc (mangle_type_decl type_decl))
           ty
           (polymorphize conv_of)
        ]
      else
        [Vb.mk
            (Pat.var' (mangle_type_decl type_decl))
            (polymorphize conv_of)
        ]
  end

  module Decoder = struct

    let deriver = M.deriver ^.^ "of_" ^ M.name

    (* n_of_ocaml *)
    let of_ n = Exp.ident & lid & n ^ "_of_" ^ M.name

    (* e => Ocaml_conv.exn e *)
    let exn e = let loc = e.pexp_loc in [%expr [%e econv "exn" ] [%e e]]

    (* Ocaml_conv.DeconstrDecoder.variant_exn *)
    let deconstr n = econv & "DeconstrDecoder" ^.^ n ^ "_exn"

    (* M.t_of_ocaml_exn for M.t *)
    let mangle_lid_exn = mangle_lid (`Suffix ("of_" ^ M.name ^ "_exn"))

    (* M.t_of_ocaml for M.t *)
    let mangle_lid = mangle_lid (`Suffix ("of_" ^ M.name))

    (* t_of_ocaml_exn for type t*)
    let mangle_type_decl_exn = mangle_type_decl (`Suffix ("of_" ^ M.name ^ "_exn"))

    (* t_of_ocaml for type t *)
    let mangle_type_decl = mangle_type_decl (`Suffix ("of_" ^ M.name))

    (* t Ocaml_conv.decoder_exn *)
    let decoder_exn typ =
      Typ.constr (lid & conv "decoder_exn") [typ]

    (* t Ocaml_conv.decoder *)
    let decoder typ =
      Typ.constr (lid & conv "decoder") [typ]

    (* type of t_of_ocaml_exn, ex. 'a Ocaml_conv.decoder -> 'a t Ocaml_conv.decoder_exn *)
    let sig_of_decoder_exn type_decl =
      let typ = Ppx_deriving.core_type_of_type_decl type_decl in
      let polymorphize = Ppx_deriving.poly_arrow_of_type_decl decoder type_decl in
      polymorphize & decoder_exn typ

    (* type of t_of_ocaml, ex. 'a Ocaml_conv.decoder -> 'a t Ocaml_conv.decoder *)
    let sig_of_decoder type_decl =
      let typ = Ppx_deriving.core_type_of_type_decl type_decl in
      let polymorphize = Ppx_deriving.poly_arrow_of_type_decl decoder type_decl in
      polymorphize & decoder typ

    let is_base_type = function
      | [%type: int       ]
      | [%type: int32     ] | [%type: Int32.t]
      | [%type: int64     ] | [%type: Int64.t]
      | [%type: nativeint ] | [%type: Nativeint.t]
      | [%type: float     ]
      | [%type: bool      ]
      | [%type: char      ]
      | [%type: string    ]
      | [%type: bytes     ]
      | [%type: [%t? _] ref]
      | [%type: [%t? _] list]
      | [%type: [%t? _] array]
      | [%type: [%t? _] option]
      | { ptyp_desc = Ptyp_arrow (_, _, _) } -> true
      | _ -> false

    let rec expr_of_typ_exn typ =
      with_loc typ.ptyp_loc & fun () ->
      match typ with
      | _ when is_base_type typ -> exn & expr_of_typ typ
      | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } ->
          let args_pp = List.map (fun typ -> [%expr [%e expr_of_typ typ]]) args in
          exn & Exp.apply' (Exp.lident (mangle_lid lid)) args_pp
      | { ptyp_desc = Ptyp_tuple typs; ptyp_loc } ->
          let loc = ptyp_loc in
          [%expr fun ?trace:(__t = []) __v ->
            [%e expr_of_tuple_exn ptyp_loc typs ]
          ]
      | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } ->
          let loc = ptyp_loc in
          [%expr fun ?trace:(__t = []) __v ->
            [%e expr_of_poly_variant_exn typ fields ]
          ]
      | { ptyp_desc = Ptyp_object (_fields, Open); ptyp_loc } ->
          raise_errorf ~loc:ptyp_loc "%s cannot be derived for open object type %s"
            deriver (string_of_core_type typ)

      | { ptyp_desc = Ptyp_object (labels, Closed); ptyp_loc } ->
          let loc = ptyp_loc in
          [%expr fun ?trace:(__t = []) __v ->
            [%e expr_of_object_exn typ labels ]
          ]
      | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ_exn typ
      | { ptyp_desc = Ptyp_var name } -> exn & Exp.var & poly_var name
      | { ptyp_loc } ->
          raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
            deriver (string_of_core_type typ)

    and expr_of_typ typ =
      with_loc typ.ptyp_loc & fun () ->
      let loc = typ.ptyp_loc in
      match typ with
      | [%type: int       ]                        -> of_ "int"
      | [%type: int32     ] | [%type: Int32.t]     -> of_ "int32"
      | [%type: int64     ] | [%type: Int64.t]     -> of_ "int64"
      | [%type: nativeint ] | [%type: Nativeint.t] -> of_ "nativeint"
      | [%type: float     ]                        -> of_ "float"
      | [%type: bool      ]                        -> of_ "bool"
      | [%type: char      ]                        -> of_ "char"
      | [%type: string    ]                        -> of_ "string"
      | [%type: bytes     ]                        -> of_ "bytes"
      | [%type: [%t? typ] ref]   ->
          [%expr [%e of_ "ref"] [%e expr_of_typ typ] ]
      | [%type: [%t? typ] list]  ->
          [%expr [%e of_ "list"] [%e expr_of_typ typ] ]
      | [%type: [%t? typ] array] ->
          [%expr [%e of_ "array"] [%e expr_of_typ typ] ]
      | [%type: [%t? typ] option] ->
          [%expr [%e of_ "option"] [%e expr_of_typ typ] ]
      | { ptyp_desc = Ptyp_arrow (_l, t1, t2) } ->
          [%expr [%e of_ "arrow"] [%e expr_of_typ t1] [%e expr_of_typ t2]]
      | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } ->
          let args_pp = List.map (fun typ -> [%expr [%e expr_of_typ typ]]) args in
          Exp.apply' (Exp.lident (mangle_lid lid)) args_pp
      | { ptyp_desc = Ptyp_tuple typs; ptyp_loc } ->
          [%expr fun ?trace:(__t = []) __v ->
            [%e econv "catch"]
              (fun () -> [%e expr_of_tuple_exn ptyp_loc typs ])
              ()
          ]
      | { ptyp_desc = Ptyp_variant (fields, _, _); (* ptyp_loc *) } ->
          [%expr fun ?trace:(__t = []) __v ->
            [%e econv "catch"]
              (fun () -> [%e expr_of_poly_variant_exn typ fields ])
              ()
          ]

      | { ptyp_desc = Ptyp_object (_fields, Open); ptyp_loc } ->
          raise_errorf ~loc:ptyp_loc "%s cannot be derived for open object type %s"
            deriver (string_of_core_type typ)

      | { ptyp_desc = Ptyp_object (labels, Closed) } ->
          [%expr fun ?trace:(__t = []) __v ->
            [%e econv "catch"]
              (fun () -> [%e expr_of_object_exn typ labels])
              ()
          ]

      | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ
      | { ptyp_desc = Ptyp_var name } ->
          [%expr [%e Exp.var & poly_var name]]
      | { ptyp_loc } ->
          raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
            deriver (string_of_core_type typ)

    and expr_of_tuple_exn ptyp_loc typs =
      (* match DeconstrDecoder.tuple_exn ~trace: __t __v with
         | [a1; ..; an] ->
             (xxx_of_ttt0_exn ~trace:(`Pos 0 :: __t) a0,
              ..
              xxx_of_tttn_exn ~trace:(`Pos n :: __t) an)
         | _ -> throw ...
      *)
      let loc = ptyp_loc in
      Exp.match_
        [%expr [%e deconstr "tuple"] ~trace: __t __v]
        [ Exp.case
            (Pat.list (List.mapi (fun i _ -> Pat.var' (argn i)) typs))
            (Exp.tuple' (List.mapi (fun i typ ->
              [%expr
                  [%e exn & expr_of_typ typ] (* XXX expr_of_typ_exn typ ? *)
                  ~trace:(`Pos [%e Exp.int i] :: __t)
                  [%e Exp.var (argn i)]
              ]) typs))
        ; Exp.case [%pat? __vs]
          [%expr
              [%e econv "throw"]
                (`Wrong_arity ([%e Exp.int & List.length typs],
                               List.length __vs,
                               None),
                 __v,
                 __t)
          ]
        ]

    and expr_of_poly_variant_exn ({ptyp_loc} as typ) row_fields =
      let cases =
        row_fields |> List.map (fun row_field ->
            match row_field.prf_desc, row_field.prf_attributes with
            | Rtag (label, true (*empty*), []), attrs -> (* `L *)
                let label' = conv_as M.name label.txt attrs in
                [ Exp.case
                    (let loc = label.loc in
                     [%pat?
                        ( [%p Pat.string label'],
                          [%p Pat.list [] ] )
                     ])
                    (Exp.variant label.txt None)
                ; Exp.case
                    (let loc = label.loc in [%pat? ( [%p Pat.string label'], args ) ])
                    (let loc = row_field.prf_loc in
                     [%expr
                        let __t = `Field [%e Exp.string & "`" ^ label'] :: __t in
                        [%e econv "throw"]
                          (`Wrong_arity (
                            [%e Exp.int 0],
                            List.length args,
                            None),
                           __v,
                           __t)
                     ])
                ]
            | Rtag (label, false, [typ]), attrs -> (* `L of typ *)
                let label' = conv_as M.name label.txt attrs in
                [ Exp.case
                    (let loc = label.loc in
                     [%pat?
                         ( [%p Pat.string label'],
                           [__v] )
                     ])
                    (let loc = row_field.prf_loc in
                     [%expr
                       let __t = `Field [%e Exp.string & "`" ^ label'] :: __t in
                       [%e Exp.variant label.txt
                         & Some [%expr [%e expr_of_typ_exn typ] ~trace:__t __v]]
                     ])
                ; Exp.case
                    (let loc = label.loc in
                     [%pat? ( [%p Pat.string label'], args ) ])
                    (let loc = row_field.prf_loc in
                     [%expr
                       let __t = `Field [%e Exp.string & "`" ^ label'] :: __t in
                       [%e econv "throw"]
                         (`Wrong_arity (
                           [%e Exp.int 1],
                           List.length args,
                           None),
                          __v,
                          __t)
                    ])
                ]
            | Rinherit ({ ptyp_desc = Ptyp_constr (_tname, []) } as _typ'), _attrs -> (* [ tname ] *)
                (*Exp.case [%pat? [%p Pat.type_ tname] as x]
                  [%expr [%e expr_of_typ typ] x]
                *)
                raise_errorf ~loc:ptyp_loc "Rinherit decoding is not supported yet"
                  deriver (string_of_core_type typ)
            | _ ->
                raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
                  deriver (string_of_core_type typ))
      in
      let loc = ptyp_loc in (* ??? *)
      Exp.match_
        [%expr [%e deconstr "poly_variant"] "<poly_var>" ~trace: __t __v]
        &
        (List.concat cases
         @ [ Exp.case [%pat? (name,_)]
              [%expr
                  [%e econv "throw"]
                   (* CR jfuruse: TODO *)
                  (`Unknown_tag ([%e Exp.string "<poly_var>"], name),
                   __v,
                   __t)
              ]
          ])

    and expr_of_object_exn ?type_name ?attrs typ ofields =
      let type_name = match type_name with
        | None -> string_of_core_type typ
        | Some s -> s
      in
      let make_fields fields =
        Exp.object_
        & Cstr.mk (Pat.any ())
        & List.map (fun (n, e) -> Cf.method_concrete (at n) e) fields
      in
      let labels =
        List.filter_map (function
            | { pof_desc= Otag (n, ty); pof_attributes=attrs; _} ->
                Some (n, ty, attrs)
            | _ -> None) ofields
      in
      expr_of_fields_exn
        ~type_name
        ~make_fields
        (* We have [?attrs] for [type t [&conv.ignore_unknown_fields] ] *)
        ~attrs: (match attrs with
                 | None -> typ.ptyp_attributes
                 | Some attrs -> attrs @ typ.ptyp_attributes)
        labels

    (* have [__t] and [__v] as free vars *)
    and expr_of_fields_exn
        ~type_name
        ~make_fields
        ~attrs (fields : (label loc * _ * _) list) =
      let leftover_field =
        match List.find_all (fun (_,ty,_) -> is_for_leftovers ty) fields with
        | [x] -> Some x
        | [] -> None
        | _ ->
            (* CR jfuruse: must use ptyp_loc *)
            failwithf "Multiple mc_leftovers for <object> is not allowed"
      in
      let ignore_unknown_fields =
        conv_ignore_unknown_fields M.name attrs
        || leftover_field <> None
      in
      let embeded_fields = List.filter_map is_for_embeded fields in
      let extract (n,typ,attrs) k =
        let name' = conv_as M.name n.txt attrs in
        match is_mc_option typ with
        | None ->
            let loc = typ.ptyp_loc in
            [%expr
             let [%p Pat.var' n.txt] =
               Meta_conv.Internal.field_assoc_exn
                 [%e Exp.string type_name]
                 [%e Exp.string name']
                 primary_fields
                 [%e econv "throw"]
                 [%e expr_of_typ_exn typ]
                 ~trace: __t __v
             in
             [%e k]
            ]
        | Some ty ->
            let loc = ty.ptyp_loc in
            [%expr
             let [%p Pat.var' n.txt] =
               Meta_conv.Internal.field_assoc_optional_exn
                 [%e Exp.string type_name]
                 [%e Exp.string name']
                 primary_fields
                 [%e expr_of_typ_exn ty]
                 ~trace: __t __v
             in
             [%e k]
            ]
      in
      let primary_fields =
        List.filter_map (fun ({txt=name_of_object_field}, _, _ as l) ->
            let name_of_leftover_field =
              Option.fmap (fun (l,_,_) -> l.txt) leftover_field
            in
            let is_left_over =
              name_of_leftover_field = Some name_of_object_field
            in
            if not is_left_over
               && not (List.exists (fun (l', _, _) ->
                   name_of_object_field = l'.txt) embeded_fields)
            then Some l
            else None) fields
      in
      let secondary_field_empty_check =
        if ignore_unknown_fields then
          let loc = Location.none in [%expr ()]
        else
          let loc = Location.none in
          [%expr
              if __secondary_fields <> [] then
                [%e econv "throw"]
                  (`Unknown_fields
                      ([%e Exp.string type_name],
                       (List.map fst __secondary_fields),
                       Obj.repr res),
                   __v,
                   __t)
          ]
      in
      (* method l = l *)
      let primaries =
        List.map (fun ({txt=name},_,_) ->
            (name, Exp.var name)) primary_fields
      in

      let scrape_embeded ({txt=l; loc}, k, typ) code =
        let return_v = match k with
          | `Embeded ->        [%expr v]
          | `Option_embeded -> [%expr Some v]
        in
        let recovery_e = match k with
          | `Embeded ->
              (* no error recovery *)
              [%expr [%e econv "throw"] __e]
          | `Option_embeded -> [%expr __secondary_fields, None]
        in
        [%expr
         let __secondary_fields, [%p Pat.var' l] = (* [%e pvar l] went into inf loop *)
           let trace = `Field [%e Exp.string l] :: __t in
           match [%e expr_of_typ typ] ~trace __v with
           | Ok v -> [], [%e return_v]
           | Error (`Unknown_fields (_, unk_fields, obj), __v', trace') when __v == __v' && trace == trace' ->
               List.filter (fun (x,_) -> List.mem x unk_fields) __secondary_fields,
             [%e
                 match k with
                 | `Embeded -> [%expr (Obj.obj obj : [%t typ]) ]
                 | `Option_embeded -> [%expr Some (Obj.obj obj : [%t typ]) ]
             ]
           | Error __e -> [%e recovery_e]
         in
         [%e code]
        ]
      in

      (* method l = l *)
      let embededs = List.map (fun ({txt=n}, _, _) ->
          (n, Exp.var n)) embeded_fields
      in

      (* method name = __secondary_fields *)
      let left_over = match leftover_field with
        | None -> []
        | Some (name, _, _) -> [ (name, Exp.var "__secondary_fields") ]
      in

      let loc = Location.none in (* XXX *)
      [%expr (* This should have the following outside: fun ?trace:(__t = []) __v ->  *)
        let primary_labels =
          [%e Exp.list & List.map (fun ({txt=name}, _, attrs) ->
              Exp.string & conv_as M.name name attrs) primary_fields
          ]
        in
        let __fields = [%e deconstr "record"] [%e Exp.string type_name ] ~trace:__t __v in
        let (primary_fields, __secondary_fields) =
          Meta_conv.Internal.filter_fields primary_labels __fields
        in
        let res, __secondary_fields =
          [%e
           List.fold_right scrape_embeded embeded_fields
             (List.fold_right extract primary_fields
                [%expr
                    [%e make_fields (primaries @ (List.map (fun ({txt},a) -> txt,a) left_over) @ embededs)],
                    [%e Exp.var "__secondary_fields"]])
          ]
        in
        [%e secondary_field_empty_check];
        res
      ]

    let sig_of_type ~path:_ type_decl =
      with_loc type_decl.ptype_loc & fun () ->
      [ Sig.value & Val.mk
          (at & mangle_type_decl_exn type_decl)
          (sig_of_decoder_exn type_decl)

      ; Sig.value & Val.mk
          (at & mangle_type_decl type_decl)
          (sig_of_decoder type_decl)
      ]

    let str_of_type ~path ({ ptype_loc = loc; ptype_attributes } as type_decl) =
      with_loc loc & fun () ->
      let type_name = String.concat "." (path @ [type_decl.ptype_name.txt]) in
      let is_gadt = match type_decl.ptype_kind with
        | Ptype_variant constrs ->
            List.exists (fun c -> c.pcd_res <> None) constrs
        | _ -> false
      in
      let of_exn = match type_decl.ptype_kind, type_decl.ptype_manifest with
        | Ptype_abstract, Some ({ ptyp_desc = Ptyp_object (labels, Closed) } as typ) ->
            [%expr fun ?trace:(__t = []) __v ->
              [%e expr_of_object_exn ~type_name typ labels]
            ]
        | Ptype_abstract, Some manifest ->
            [%expr
                fun ?trace:(__t = []) __v ->
                  [%e expr_of_typ_exn manifest] ~trace:__t __v
            ]
        | Ptype_variant constrs, _ ->
            let cases =
              constrs |> List.map begin fun { pcd_name = { txt = constr_name }; pcd_args; pcd_attributes = attrs } ->
                let constr_name' = conv_as M.name constr_name attrs in
                match pcd_args with
                | Pcstr_tuple [cty] ->
                    (* | (constr_name, args) ->
                           let arg =
                             match args with
                             | [arg] -> arg
                             | _ -> XXX_conv.Constr.tuple args
                           in
                           let __t = `Field "constr_name" :: __t in
                           Constr_name ( expr_of_typ_exn cty ~trace:(`Pos 0 :: __t) arg)
                    *)
                    [ Exp.case
                        (* (<constr_name'>, args) -> *)
                        [%pat?
                            ( [%p Pat.string constr_name'], args )
                        ]
                        [%expr
                           let arg = match args with [arg] -> arg | _ -> [%e Encoder.constr "tuple"] args in
                           let __t = `Field [%e Exp.string constr_name'] :: __t in
                           [%e
                               Exp.construct (lid constr_name)
                                 (Some
                                    [%expr
                                      [%e expr_of_typ_exn cty]
                                        ~trace:(`Pos [%e Exp.int 0] :: __t)
                                        arg])
                           ]
                        ]
                    ]
                | Pcstr_tuple ctys ->
                    (* | (constr_name, [a0; ..; an]) ->
                           let __t = `Field "constr_name" :: __t in
                           Constr_name ( expr_of_typ_exn tyi ~trace:(`Pos i :: __t) ai, .. )
                       | (constr_name, args) -> ERROR
                    *)
                    [ Exp.case
                        (* (<constr_name'>, [a0; ..; an]) -> *)
                        [%pat?
                            ( [%p Pat.string constr_name'],
                              [%p Pat.list (List.mapi (fun i _ -> Pat.var' (argn i)) ctys)]
                            )
                        ]
                        [%expr
                           let __t = `Field [%e Exp.string constr_name'] :: __t in
                           [%e
                               (* <constr_name>(a0, ..., an) *)
                               Exp.construct (lid constr_name)
                                 (match
                                    List.mapi (fun i typ ->
                                     [%expr
                                         [%e expr_of_typ_exn typ]
                                         ~trace:(`Pos [%e Exp.int i] :: __t)
                                         [%e Exp.var (argn i) ]
                                     ] ) ctys
                                      with
                                      | [] -> None
                                      | [x] -> Some x
                                      | xs -> Some (Exp.tuple' xs)
                                 )
                           ]
                        ]
                    ; Exp.case
                        [%pat? ( [%p Pat.string constr_name'], args)]
                        [%expr [%e econv "throw"]
                            (`Wrong_arity (
                                [%e Exp.int (List.length ctys)],
                                List.length args,
                                Some ([%e Exp.string type_name],
                                      [%e Exp.string constr_name])
                             ),
                             __v,
                             __t)
                        ]
                    ]
                | Pcstr_record labels ->
                    let constr_record fields =
                      let fields = List.map (fun (l,x) -> lid l, x) fields in
                      Exp.construct (lid constr_name) (Some ( Exp.record fields None ))
                    in
                    (* <constr_name'> __v -> ... *)
                    [ Exp.case
                        [%pat? ( [%p Pat.string constr_name'], [ [%p Pat.var' "__v" ] ] ) ]
                        [%expr
                           let __t = `Field [%e Exp.string constr_name'] :: __t in
                           [%e expr_of_fields_exn
                               ~type_name
                               ~make_fields: constr_record
                               ~attrs: ptype_attributes
                             & List.map (fun pld -> (pld.pld_name,
                                                     pld.pld_type,
                                                     pld.pld_attributes
                                                      )) labels
                           ]
                        ]
                    ; Exp.case
                        [%pat? ( [%p Pat.string constr_name'], args)]
                        [%expr [%e econv "throw"]
                            (`Wrong_arity (1,
                                List.length args,
                                Some ([%e Exp.string type_name], [%e Exp.string constr_name])
                             ),
                             __v,
                             __t)
                        ]
                    ]
              end
            in
            [%expr fun ?trace:(__t = []) __v ->
              let __t = `Node __v :: __t in
              [%e Exp.match_
                  [%expr [%e deconstr "variant"]
                           [%e Exp.string type_name]
                           ~trace:__t
                           __v
                  ]
                  (List.concat cases
                   @ [ Exp.case
                         [%pat? (name, _)]
                         [%expr
                           [%e econv "throw"]
                             (`Unknown_tag ([%e Exp.string type_name], name),
                              __v,
                              __t)
                         ]
                     ])
              ]
            ]

        | Ptype_record labels, _ ->

            [%expr fun ?trace:(__t = []) __v ->
              [%e expr_of_fields_exn
                  ~type_name
                  ~make_fields: (fun lexp -> Exp.record (List.map (fun (n,e) -> lid n, e) lexp) None)
                  ~attrs: ptype_attributes
                & List.map (fun pld -> (pld.pld_name,
                                        pld.pld_type,
                                        pld.pld_attributes
                                       )) labels
              ]
            ]

      | Ptype_abstract, None ->
          raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver
      | Ptype_open, _        ->
          raise_errorf ~loc "%s cannot be derived for open types" deriver
      in
      let polymorphize e = Ppx_deriving.poly_fun_of_type_decl type_decl e in
      if is_gadt then
        let ty_exn = sig_of_decoder_exn type_decl in
        let ty = sig_of_decoder type_decl in
        [ vb_newtypes
            (at ~loc:type_decl.ptype_loc (mangle_type_decl_exn type_decl))
            ty_exn
            (polymorphize of_exn)
        ; vb_newtypes
            (at ~loc:type_decl.ptype_loc (mangle_type_decl type_decl))
            ty
            (polymorphize
               (let args_pp = List.map (fun (typ,_) -> [%expr [%e expr_of_typ typ]]) type_decl.ptype_params in
                [%expr
                    fun ?trace:__t __v ->
                      [%e econv "result"]
                        [%e
                         let lid = Longident.Lident type_decl.ptype_name.txt in
                         Exp.apply' (Exp.lident (mangle_lid_exn lid)) args_pp ]
                        ?trace:__t __v
                ]))
        ]
      else
        [ Vb.mk
          (* We need here type constraint since ocaml cannot
             infer the option label of poly_a *)
          (Pat.constraint_
             (Pat.var' (mangle_type_decl_exn type_decl))
             (sig_of_decoder_exn type_decl))
          (polymorphize of_exn)
        ; Vb.mk
          (Pat.var' (mangle_type_decl type_decl))
          (polymorphize
             (let args_pp = List.map (fun (typ,_) -> [%expr [%e expr_of_typ typ]]) type_decl.ptype_params in
             [%expr
                 fun ?trace:__t __v ->
                 [%e econv "result"]
                 [%e
                  let lid = Longident.Lident type_decl.ptype_name.txt in
                  Exp.apply' (Exp.lident (mangle_lid_exn lid)) args_pp ]
                   ?trace:__t __v
             ]))
      ]

  end
end

let parse_option s =
  match String.is_prefix' "of_" s, String.is_postfix' "_of" s with
  | None   , None   -> s, `Both
  | Some s , None   -> s, `Decoder
  | None   , Some s -> s, `Encoder
  | _ -> failwith "You really want to have of_xxx_of thing???"

(** Get the labels from [{ x; y }] *)
let parse_options deriver = List.map (fun (name, expr) ->
    match expr with
    | { pexp_desc = Pexp_ident {txt = Lident n} } when n = name -> name
    | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name)

let big_one () =

  let deriver = "conv" in

  let structure ~options ~path type_decls =
    let open List in
    let targets = parse_options deriver options in
    concat & flip map targets (fun s ->
        let name, which = parse_option s in
        let module M = Make(struct
          let deriver = deriver
          let name = name
          let type_ = String.capitalize_ascii name ^ ".t"
          let conv = String.capitalize_ascii name ^ "_conv"
        end) in
        let has_gadt = exists is_gadt type_decls in
        let enc () =
          str_value_maybe_rec
          & concat_map (M.Encoder.str_of_type ~is_gadt:has_gadt ~path) type_decls
        in
        let dec () =
          str_value_maybe_rec
          & concat_map (M.Decoder.str_of_type ~path) type_decls
        in
        match which with
        | `Both -> enc () @ dec ()
        | `Decoder -> dec ()
        | `Encoder -> enc ())
  in

  let signature ~options ~path type_decls =
    let open List in
    let targets = parse_options deriver options in
    concat & concat & concat & flip map targets (fun s ->
      let name, which = parse_option s in
      let module M = Make(struct
        let deriver = deriver
        let name = name
        let type_ = String.capitalize_ascii name ^ ".t"
        let conv = String.capitalize_ascii name ^ "_conv"
      end) in
      map (fun td ->
        let enc () = M.Encoder.sig_of_type ~path td in
        let dec () = M.Decoder.sig_of_type ~path td in
        match which with
        | `Both -> [enc (); dec ()]
        | `Decoder -> [dec ()]
        | `Encoder -> [enc ()]) type_decls)
  in

  let open Ppx_deriving in
  register & create deriver
    ~type_decl_str: structure
    ~type_decl_sig: signature
    ()

let splitted name =
(*  let open List in *)
  let module M = Make(struct
    let deriver = "ppx_meta_conv"
    let name = name
    let type_ = String.capitalize_ascii name ^ ".t"
    let conv = String.capitalize_ascii name ^ "_conv"
  end)
  in

  let open Ppx_deriving in
  (* [%derive.xxx_of: ty] *)
  register & create (name ^ "_of")
    ~core_type: (M.Encoder.expr_of_typ [])
    ();

  (* [%derive.of_xxx: ty] *)
  register & create ("of_" ^ name)
    ~core_type: (M.Decoder.expr_of_typ) ();

  (* [%derive.of_xxx_exn: ty] *)
  register & create ("of_" ^ name ^ "_exn")
    ~core_type: (M.Decoder.expr_of_typ_exn) ()