Source file expand_sexp_of.ml

open! Base
open! Ppxlib
open Ast_builder.Default
open Helpers
open Lifted.Monad_infix

(* Generates the signature for type conversion to S-expressions *)
module Sig_generate_sexp_of = struct
  let type_of_sexp_of ~loc t =
    let loc = { loc with loc_ghost = true } in
    [%type: [%t t] -> Sexplib0.Sexp.t]
  ;;

  let mk_type td = combinator_type_of_type_declaration td ~f:type_of_sexp_of

  let mk_sig ~loc:_ ~path:_ (_rf, tds) =
    List.map tds ~f:(fun td ->
      let loc = td.ptype_loc in
      psig_value
        ~loc
        (value_description
           ~loc
           ~name:(Located.map (( ^ ) "sexp_of_") td.ptype_name)
           ~type_:(mk_type td)
           ~prim:[]))
  ;;

  let mk_sig_exn ~loc:_ ~path:_ _te = []
end

module Str_generate_sexp_of = struct
  module Types_being_defined = struct
    type t =
      | Nonrec
      | Rec of Set.M(String).t

    let to_rec_flag = function
      | Nonrec -> Nonrecursive
      | Rec _ -> Recursive
    ;;

    let to_values_being_defined = function
      | Nonrec -> Set.empty (module String)
      | Rec types -> Set.map (module String) types ~f:(fun s -> "sexp_of_" ^ s)
    ;;
  end

  let sexp_of_type_constr ~loc id args =
    type_constr_conv ~loc id ~f:(fun s -> "sexp_of_" ^ s) args
  ;;

  (* Conversion of types *)
  let rec sexp_of_type ~renaming typ : Conversion.t =
    let loc = { typ.ptyp_loc with loc_ghost = true } in
    match Ppxlib_jane.Jane_syntax.Core_type.of_ast typ with
    | Some (Jtyp_tuple alist, (_ : attributes)) ->
      Conversion.of_lambda [ sexp_of_labeled_tuple ~renaming ~loc alist ]
    | Some (Jtyp_layout _, _) | None ->
      (match typ with
       | _ when Option.is_some (Attribute.get Attrs.opaque typ) ->
         Conversion.of_reference_exn [%expr Sexplib0.Sexp_conv.sexp_of_opaque]
       | [%type: _] ->
         Conversion.of_lambda [ ppat_any ~loc --> [%expr Sexplib0.Sexp.Atom "_"] ]
       | [%type: [%t? _] sexp_opaque] ->
         Conversion.of_reference_exn [%expr Sexplib0.Sexp_conv.sexp_of_opaque]
       | { ptyp_desc = Ptyp_tuple tp; _ } ->
         Conversion.of_lambda [ sexp_of_tuple ~renaming (loc, tp) ]
       | { ptyp_desc = Ptyp_var parm; _ } ->
         (match Renaming.binding_kind renaming parm ~loc with
          | Universally_bound fresh ->
            Conversion.of_reference_exn (Fresh_name.expression fresh)
          | Existentially_bound -> sexp_of_type ~renaming [%type: _])
       | { ptyp_desc = Ptyp_constr (id, args); _ } ->
         Conversion.of_reference_exn
           (sexp_of_type_constr
              ~loc
              id
              (List.map args ~f:(fun tp ->
                 Conversion.to_expression ~loc (sexp_of_type ~renaming tp))))
       | { ptyp_desc = Ptyp_arrow (_, _, _); _ } ->
         Conversion.of_lambda
           [ ppat_any ~loc
             --> [%expr Sexplib0.Sexp_conv.sexp_of_fun Sexplib0.Sexp_conv.ignore]
           ]
       | { ptyp_desc = Ptyp_variant (row_fields, Closed, _); _ } ->
         sexp_of_variant ~renaming (loc, row_fields)
       | { ptyp_desc = Ptyp_poly (parms, poly_tp); _ } ->
         sexp_of_poly ~renaming parms poly_tp
       | { ptyp_desc = Ptyp_variant (_, Open, _); _ }
       | { ptyp_desc = Ptyp_object (_, _); _ }
       | { ptyp_desc = Ptyp_class (_, _); _ }
       | { ptyp_desc = Ptyp_alias (_, _); _ }
       | { ptyp_desc = Ptyp_package _; _ }
       | { ptyp_desc = Ptyp_extension _; _ } ->
         Location.raise_errorf ~loc "Type unsupported for ppx [sexp_of] conversion")

  (* Conversion of (unlabeled) tuples *)
  and sexp_of_tuple ~renaming (loc, tps) =
    let fps = List.map ~f:(fun tp -> sexp_of_type ~renaming tp) tps in
    let ({ bindings; arguments; converted } : Conversion.Apply_all.t) =
      Conversion.apply_all ~loc fps
    in
    let in_expr = [%expr Sexplib0.Sexp.List [%e elist ~loc converted]] in
    let expr = pexp_let ~loc Nonrecursive bindings in_expr in
    ppat_tuple ~loc arguments --> expr

  (* Conversion of labeled tuples *)
  and sexp_of_labeled_tuple ~renaming ~loc alist =
    assert (Labeled_tuple.is_valid alist);
    let ({ bindings; arguments; converted } : Conversion.Apply_all.t) =
      List.map alist ~f:(fun (_, core_type) -> sexp_of_type ~renaming core_type)
      |> Conversion.apply_all ~loc
    in
    let expr =
      let sexp_exprs =
        (* Constructor inference allows to to leave off [Sexplib0.Sexp.] here. *)
        List.map2_exn alist converted ~f:(fun (label_option, _) expr ->
          [%expr
            List
              [ Atom [%e estring ~loc (Labeled_tuple.atom_of_label label_option)]
              ; [%e expr]
              ]])
      in
      [%expr Sexplib0.Sexp.List [%e elist ~loc sexp_exprs]]
      |> pexp_let ~loc Nonrecursive bindings
    in
    let pat =
      ( List.map2_exn alist arguments ~f:(fun (label_option, _) arg -> label_option, arg)
      , Closed )
      |> Ppxlib_jane.Jane_syntax.Labeled_tuples.pat_of ~loc
    in
    pat --> expr

  (* Conversion of variant types *)
  and sexp_of_variant ~renaming ((loc, row_fields) : Location.t * row_field list)
    : Conversion.t
    =
    let item row =
      match row.prf_desc with
      | Rtag ({ txt = cnstr; _ }, true, []) ->
        ppat_variant ~loc cnstr None
        --> [%expr Sexplib0.Sexp.Atom [%e estring ~loc cnstr]]
      | Rtag ({ txt = cnstr; _ }, _, [ tp ])
        when Option.is_some (Attribute.get Attrs.list_poly row) ->
        (match tp with
         | [%type: [%t? tp] list] ->
           let cnv_expr = Conversion.to_expression ~loc (sexp_of_type ~renaming tp) in
           let name = Fresh_name.create "l" ~loc in
           ppat_variant ~loc cnstr (Some (Fresh_name.pattern name))
           --> [%expr
                 Sexplib0.Sexp.List
                   (Sexplib0.Sexp.Atom [%e estring ~loc cnstr]
                    :: Sexplib0.Sexp_conv.list_map
                         [%e cnv_expr]
                         [%e Fresh_name.expression name])]
         | _ -> Attrs.invalid_attribute ~loc Attrs.list_poly "_ list")
      | Rtag ({ txt = cnstr; _ }, _, [ [%type: [%t? tp] sexp_list] ]) ->
        let cnv_expr = Conversion.to_expression ~loc (sexp_of_type ~renaming tp) in
        let name = Fresh_name.create "l" ~loc in
        ppat_variant ~loc cnstr (Some (Fresh_name.pattern name))
        --> [%expr
              Sexplib0.Sexp.List
                (Sexplib0.Sexp.Atom [%e estring ~loc cnstr]
                 :: Sexplib0.Sexp_conv.list_map
                      [%e cnv_expr]
                      [%e Fresh_name.expression name])]
      | Rtag ({ txt = cnstr; _ }, false, [ tp ]) ->
        let cnstr_expr = [%expr Sexplib0.Sexp.Atom [%e estring ~loc cnstr]] in
        let fresh = Fresh_name.create "v" ~loc in
        let cnstr_arg =
          Conversion.apply ~loc (sexp_of_type ~renaming tp) (Fresh_name.expression fresh)
        in
        let expr = [%expr Sexplib0.Sexp.List [%e elist ~loc [ cnstr_expr; cnstr_arg ]]] in
        ppat_variant ~loc cnstr (Some (Fresh_name.pattern fresh)) --> expr
      | Rinherit { ptyp_desc = Ptyp_constr (id, []); _ } ->
        let name = Fresh_name.create "v" ~loc in
        ppat_alias ~loc (ppat_type ~loc id) (Fresh_name.to_string_loc name)
        --> sexp_of_type_constr ~loc id [ Fresh_name.expression name ]
      | Rtag (_, true, [ _ ]) | Rtag (_, _, _ :: _ :: _) ->
        Location.raise_errorf ~loc "unsupported: polymorphic variant intersection type"
      | Rinherit ({ ptyp_desc = Ptyp_constr (id, _ :: _); _ } as typ) ->
        let call = Conversion.to_expression ~loc (sexp_of_type ~renaming typ) in
        let name = Fresh_name.create "v" ~loc in
        ppat_alias ~loc (ppat_type ~loc id) (Fresh_name.to_string_loc name)
        --> [%expr [%e call] [%e Fresh_name.expression name]]
      | Rinherit _ ->
        Location.raise_errorf
          ~loc
          "unsupported: polymorphic variant with invalid (non-identifier) inherited type"
      | Rtag (_, false, []) ->
        Location.raise_errorf ~loc "unsupported: polymorphic variant empty type"
    in
    Conversion.of_lambda (List.map ~f:item row_fields)

  (* Polymorphic record fields *)
  and sexp_of_poly ~renaming parms tp =
    let loc = tp.ptyp_loc in
    let renaming =
      List.fold_left
        parms
        ~init:renaming
        ~f:(Renaming.add_universally_bound ~prefix:"_of_")
    in
    let bindings =
      let mk_binding parm =
        let name =
          match Renaming.binding_kind renaming parm.txt ~loc:parm.loc with
          | Universally_bound name -> name
          | Existentially_bound -> assert false
        in
        value_binding
          ~loc
          ~pat:(Fresh_name.pattern name)
          ~expr:[%expr Sexplib0.Sexp_conv.sexp_of_opaque]
      in
      List.map ~f:mk_binding parms
    in
    Conversion.bind (sexp_of_type ~renaming tp) bindings
  ;;

  (* Conversion of record types *)

  let mk_rec_patt loc patt name fresh =
    let p = Loc.make (Longident.Lident name) ~loc, Fresh_name.pattern fresh in
    patt @ [ p ]
  ;;

  type is_empty_expr =
    | Inspect_value of (location -> expression -> expression)
    | Inspect_sexp of (cnv_expr:expression -> location -> expression -> expression)

  let sexp_of_record_field ~renaming ~bnds patt expr name tp ?sexp_of is_empty_expr =
    let loc = tp.ptyp_loc in
    let fresh = Fresh_name.create name ~loc in
    let patt = mk_rec_patt loc patt name fresh in
    let cnv_expr = Conversion.to_expression ~loc (sexp_of_type ~renaming tp) in
    let cnv_expr =
      match sexp_of with
      | None -> cnv_expr
      | Some sexp_of -> [%expr [%e sexp_of] [%e cnv_expr]]
    in
    let bnd = Fresh_name.create "bnd" ~loc in
    let arg = Fresh_name.create "arg" ~loc in
    let expr =
      [%expr
        let [%p Fresh_name.pattern bnds] =
          [%e
            match is_empty_expr with
            | Inspect_value is_empty_expr ->
              [%expr
                if [%e is_empty_expr loc (Fresh_name.expression fresh)]
                then [%e Fresh_name.expression bnds]
                else (
                  let [%p Fresh_name.pattern arg] =
                    [%e cnv_expr] [%e Fresh_name.expression fresh]
                  in
                  let [%p Fresh_name.pattern bnd] =
                    Sexplib0.Sexp.List
                      [ Sexplib0.Sexp.Atom [%e estring ~loc name]
                      ; [%e Fresh_name.expression arg]
                      ]
                  in
                  ([%e Fresh_name.expression bnd] :: [%e Fresh_name.expression bnds]
                    : _ Stdlib.List.t))]
            | Inspect_sexp is_empty_expr ->
              [%expr
                let [%p Fresh_name.pattern arg] =
                  [%e cnv_expr] [%e Fresh_name.expression fresh]
                in
                if [%e is_empty_expr ~cnv_expr loc (Fresh_name.expression arg)]
                then [%e Fresh_name.expression bnds]
                else (
                  let [%p Fresh_name.pattern bnd] =
                    Sexplib0.Sexp.List
                      [ Sexplib0.Sexp.Atom [%e estring ~loc name]
                      ; [%e Fresh_name.expression arg]
                      ]
                  in
                  ([%e Fresh_name.expression bnd] :: [%e Fresh_name.expression bnds]
                    : _ Stdlib.List.t))]]
        in
        [%e expr]]
    in
    patt, expr
  ;;

  let disallow_type_variables_and_recursive_occurrences
    ~types_being_defined
    ~loc
    ~attr_name
    tp
    =
    let disallow_variables =
      let iter =
        object
          inherit Ast_traverse.iter as super

          method! core_type_desc =
            function
            | Ptyp_var v ->
              Location.raise_errorf
                ~loc
                "[@%s] was used, but the type of the field contains a type variable: '%s.\n\
                 Comparison is not avaiable for type variables.\n\
                 Consider using [@sexp_drop_if _] or [@sexp_drop_default.sexp] instead."
                attr_name
                v
            | t -> super#core_type_desc t
        end
      in
      iter#core_type
    in
    let disallow_recursive_occurrences =
      match (types_being_defined : Types_being_defined.t) with
      | Nonrec -> fun _ -> ()
      | Rec types_being_defined ->
        let iter =
          object
            inherit Ast_traverse.iter as super

            method! core_type_desc =
              function
              | Ptyp_constr ({ loc = _; txt = Lident s }, _) as t ->
                if Set.mem types_being_defined s
                then
                  Location.raise_errorf
                    ~loc
                    "[@%s] was used, but the type of the field contains a type defined \
                     in the current recursive block: %s.\n\
                     This is not supported.\n\
                     Consider using [@sexp_drop_if _] or [@sexp_drop_default.sexp] \
                     instead."
                    attr_name
                    s;
                super#core_type_desc t
              | t -> super#core_type_desc t
          end
        in
        iter#core_type
    in
    disallow_variables tp;
    disallow_recursive_occurrences tp
  ;;

  let sexp_of_default_field
    ~types_being_defined
    how
    ~renaming
    ~bnds
    patt
    expr
    name
    tp
    ?sexp_of
    default
    =
    let is_empty =
      let inspect_value equality_f =
        Inspect_value (fun loc expr -> [%expr [%e equality_f loc] [%e default] [%e expr]])
      in
      match (how : Record_field_attrs.Sexp_of.Drop.t) with
      | Sexp ->
        Inspect_sexp
          (fun ~cnv_expr loc sexp_expr ->
            [%expr Sexplib0.Sexp_conv.( = ) ([%e cnv_expr] [%e default]) [%e sexp_expr]])
        |> Lifted.return
      | No_arg ->
        inspect_value (fun loc ->
          [%expr
            Sexplib0.Sexp_conv.( = ) [@ocaml.ppwarning
                                       "[@sexp_drop_default] is deprecated: please use \
                                        one of:\n\
                                        - [@sexp_drop_default f] and give an explicit \
                                        equality function ([f = Poly.(=)] corresponds to \
                                        the old behavior)\n\
                                        - [@sexp_drop_default.compare] if the type \
                                        supports [%compare]\n\
                                        - [@sexp_drop_default.equal] if the type \
                                        supports [%equal]\n\
                                        - [@sexp_drop_default.sexp] if you want to \
                                        compare the sexp representations\n"]])
        |> Lifted.return
      | Func lifted -> lifted >>| fun f -> inspect_value (fun _ -> f)
      | Compare ->
        inspect_value (fun loc ->
          disallow_type_variables_and_recursive_occurrences
            ~types_being_defined
            ~attr_name:"sexp_drop_default.compare"
            ~loc
            tp;
          [%expr [%compare.equal: [%t tp]]])
        |> Lifted.return
      | Equal ->
        inspect_value (fun loc ->
          disallow_type_variables_and_recursive_occurrences
            ~types_being_defined
            ~attr_name:"sexp_drop_default.equal"
            ~loc
            tp;
          [%expr [%equal: [%t tp]]])
        |> Lifted.return
    in
    is_empty >>| sexp_of_record_field ~renaming ~bnds patt expr name tp ?sexp_of
  ;;

  let sexp_of_label_declaration_list ~types_being_defined ~renaming loc flds ~wrap_expr =
    let bnds = Fresh_name.create "bnds" ~loc in
    let list_empty_expr =
      Inspect_value
        (fun loc lst ->
          [%expr
            match [%e lst] with
            | [] -> true
            | _ -> false])
    in
    let array_empty_expr =
      Inspect_value
        (fun loc arr ->
          [%expr
            match [%e arr] with
            | [||] -> true
            | _ -> false])
    in
    let coll lifted ld =
      lifted
      >>= fun ((patt : (Longident.t loc * pattern) list), expr) ->
      let name = ld.pld_name.txt in
      let loc = ld.pld_name.loc in
      let fresh = Fresh_name.create name ~loc in
      match Record_field_attrs.Sexp_of.create ~loc ld with
      | Sexp_option tp ->
        let v = Fresh_name.create "v" ~loc in
        let bnd = Fresh_name.create "bnd" ~loc in
        let arg = Fresh_name.create "arg" ~loc in
        let patt = mk_rec_patt loc patt name fresh in
        let vname = Fresh_name.expression v in
        let cnv_expr = Conversion.apply ~loc (sexp_of_type ~renaming tp) vname in
        let expr =
          [%expr
            let [%p Fresh_name.pattern bnds] =
              match [%e Fresh_name.expression fresh] with
              | Stdlib.Option.None -> [%e Fresh_name.expression bnds]
              | Stdlib.Option.Some [%p Fresh_name.pattern v] ->
                let [%p Fresh_name.pattern arg] = [%e cnv_expr] in
                let [%p Fresh_name.pattern bnd] =
                  Sexplib0.Sexp.List
                    [ Sexplib0.Sexp.Atom [%e estring ~loc name]
                    ; [%e Fresh_name.expression arg]
                    ]
                in
                ([%e Fresh_name.expression bnd] :: [%e Fresh_name.expression bnds]
                  : _ Stdlib.List.t)
            in
            [%e expr]]
        in
        Lifted.return (patt, expr)
      | Sexp_bool ->
        let patt = mk_rec_patt loc patt name fresh in
        let bnd = Fresh_name.create "bnd" ~loc in
        let expr =
          [%expr
            let [%p Fresh_name.pattern bnds] =
              if [%e Fresh_name.expression fresh]
              then (
                let [%p Fresh_name.pattern bnd] =
                  Sexplib0.Sexp.List [ Sexplib0.Sexp.Atom [%e estring ~loc name] ]
                in
                ([%e Fresh_name.expression bnd] :: [%e Fresh_name.expression bnds]
                  : _ Stdlib.List.t))
              else [%e Fresh_name.expression bnds]
            in
            [%e expr]]
        in
        Lifted.return (patt, expr)
      | Sexp_list tp ->
        sexp_of_record_field
          ~renaming
          ~bnds
          patt
          expr
          name
          tp
          ~sexp_of:
            (* deliberately using whatever [sexp_of_list] is in scope *)
            [%expr sexp_of_list]
          list_empty_expr
        |> Lifted.return
      | Sexp_array tp ->
        sexp_of_record_field
          ~renaming
          ~bnds
          patt
          expr
          name
          tp
          ~sexp_of:
            (* deliberately using whatever [sexp_of_array] is in scope *)
            [%expr sexp_of_array]
          array_empty_expr
        |> Lifted.return
      | Specific (Drop_default how) ->
        let tp = ld.pld_type in
        (match Attribute.get Attrs.default ld with
         | None -> Location.raise_errorf ~loc "no default to drop"
         | Some { to_lift = default } ->
           Record_field_attrs.lift_default ~loc ld default
           >>= sexp_of_default_field
                 ~types_being_defined
                 how
                 ~renaming
                 ~bnds
                 patt
                 expr
                 name
                 tp)
      | Specific (Drop_if test) ->
        test
        >>| fun test ->
        let tp = ld.pld_type in
        sexp_of_record_field
          ~renaming
          ~bnds
          patt
          expr
          name
          tp
          (Inspect_value (fun loc expr -> [%expr [%e test] [%e expr]]))
      | Omit_nil ->
        let tp = ld.pld_type in
        let patt = mk_rec_patt loc patt name fresh in
        let vname = Fresh_name.expression fresh in
        let arg = Fresh_name.create "arg" ~loc in
        let cnv_expr = Conversion.apply ~loc (sexp_of_type ~renaming tp) vname in
        let bnds_expr =
          [%expr
            match [%e cnv_expr] with
            | Sexplib0.Sexp.List [] -> [%e Fresh_name.expression bnds]
            | [%p Fresh_name.pattern arg] ->
              (Sexplib0.Sexp.List
                 [ Sexplib0.Sexp.Atom [%e estring ~loc name]
                 ; [%e Fresh_name.expression arg]
                 ]
               :: [%e Fresh_name.expression bnds]
                : _ Stdlib.List.t)]
        in
        ( patt
        , [%expr
            let [%p Fresh_name.pattern bnds] = [%e bnds_expr] in
            [%e expr]] )
        |> Lifted.return
      | Specific Keep ->
        let tp = ld.pld_type in
        let patt = mk_rec_patt loc patt name fresh in
        let vname = Fresh_name.expression fresh in
        let arg = Fresh_name.create "arg" ~loc in
        let cnv_expr = Conversion.apply ~loc (sexp_of_type ~renaming tp) vname in
        let bnds_expr =
          [%expr
            let [%p Fresh_name.pattern arg] = [%e cnv_expr] in
            (Sexplib0.Sexp.List
               [ Sexplib0.Sexp.Atom [%e estring ~loc name]
               ; [%e Fresh_name.expression arg]
               ]
             :: [%e Fresh_name.expression bnds]
              : _ Stdlib.List.t)]
        in
        ( patt
        , [%expr
            let [%p Fresh_name.pattern bnds] = [%e bnds_expr] in
            [%e expr]] )
        |> Lifted.return
    in
    let init_expr = wrap_expr (Fresh_name.expression bnds) in
    List.fold_left ~f:coll ~init:(Lifted.return ([], init_expr)) flds
    >>| fun (patt, expr) ->
    ( ppat_record ~loc patt Closed
    , [%expr
        let [%p Fresh_name.pattern bnds] = ([] : _ Stdlib.List.t) in
        [%e expr]] )
  ;;

  (* Conversion of sum types *)

  let branch_sum
    row
    inline_attr
    ~types_being_defined
    renaming
    ~loc
    constr_lid
    constr_str
    args
    =
    match args with
    | Pcstr_record lds ->
      let cnstr_expr = [%expr Sexplib0.Sexp.Atom [%e constr_str]] in
      sexp_of_label_declaration_list
        ~types_being_defined
        ~renaming
        loc
        lds
        ~wrap_expr:(fun expr -> [%expr Sexplib0.Sexp.List ([%e cnstr_expr] :: [%e expr])])
      >>| fun (patt, expr) -> ppat_construct ~loc constr_lid (Some patt) --> expr
    | Pcstr_tuple pcd_args ->
      (match pcd_args with
       | [] ->
         ppat_construct ~loc constr_lid None
         --> [%expr Sexplib0.Sexp.Atom [%e constr_str]]
         |> Lifted.return
       | args ->
         (match args with
          | [ tp ] when Option.is_some (Attribute.get inline_attr row) ->
            (match tp with
             | [%type: [%t? tp] list] ->
               let cnv_expr = Conversion.to_expression ~loc (sexp_of_type ~renaming tp) in
               let name = Fresh_name.create "l" ~loc in
               ppat_construct ~loc constr_lid (Some (Fresh_name.pattern name))
               --> [%expr
                     Sexplib0.Sexp.List
                       (Sexplib0.Sexp.Atom [%e constr_str]
                        :: Sexplib0.Sexp_conv.list_map
                             [%e cnv_expr]
                             [%e Fresh_name.expression name])]
             | _ -> Attrs.invalid_attribute ~loc inline_attr "_ list")
          | [ [%type: [%t? tp] sexp_list] ] ->
            let cnv_expr = Conversion.to_expression ~loc (sexp_of_type ~renaming tp) in
            let name = Fresh_name.create "l" ~loc in
            ppat_construct ~loc constr_lid (Some (Fresh_name.pattern name))
            --> [%expr
                  Sexplib0.Sexp.List
                    (Sexplib0.Sexp.Atom [%e constr_str]
                     :: Sexplib0.Sexp_conv.list_map
                          [%e cnv_expr]
                          [%e Fresh_name.expression name])]
          | _ ->
            let sexp_of_args = List.map ~f:(sexp_of_type ~renaming) args in
            let cnstr_expr = [%expr Sexplib0.Sexp.Atom [%e constr_str]] in
            let ({ bindings; arguments; converted } : Conversion.Apply_all.t) =
              Conversion.apply_all ~loc sexp_of_args
            in
            let patt =
              match arguments with
              | [ arg ] -> arg
              | _ -> ppat_tuple ~loc arguments
            in
            ppat_construct ~loc constr_lid (Some patt)
            --> pexp_let
                  ~loc
                  Nonrecursive
                  bindings
                  [%expr Sexplib0.Sexp.List [%e elist ~loc (cnstr_expr :: converted)]])
         |> Lifted.return)
  ;;

  let sexp_of_sum ~types_being_defined ~renaming tps cds =
    List.map cds ~f:(fun cd ->
      let renaming =
        Renaming.with_constructor_declaration renaming ~type_parameters:tps cd
      in
      let constr_lid = Located.map lident cd.pcd_name in
      let constr_str = estring ~loc:cd.pcd_name.loc cd.pcd_name.txt in
      branch_sum
        cd
        Attrs.list_variant
        ~types_being_defined
        renaming
        ~loc:cd.pcd_loc
        constr_lid
        constr_str
        cd.pcd_args)
    |> Lifted.all
    >>| Conversion.of_lambda
  ;;

  (* Empty type *)
  let sexp_of_nil loc = Conversion.of_lambda [ ppat_any ~loc --> [%expr assert false] ]

  (* Generate code from type definitions *)

  let sexp_of_td ~types_being_defined td =
    let td = name_type_params_in_td td in
    let tps = List.map td.ptype_params ~f:get_type_param_name in
    let { ptype_name = { txt = type_name; loc = _ }; ptype_loc = loc; _ } = td in
    let renaming = Renaming.of_type_declaration td ~prefix:"_of_" in
    let body =
      let body =
        match td.ptype_kind with
        | Ptype_variant cds ->
          sexp_of_sum
            ~renaming
            ~types_being_defined
            (List.map tps ~f:(fun x -> x.txt))
            cds
        | Ptype_record lds ->
          sexp_of_label_declaration_list
            ~renaming
            loc
            lds
            ~types_being_defined
            ~wrap_expr:(fun expr -> [%expr Sexplib0.Sexp.List [%e expr]])
          >>| fun (patt, expr) -> Conversion.of_lambda [ patt --> expr ]
        | Ptype_open ->
          Location.raise_errorf ~loc "ppx_sexp_conv: open types not supported"
        | Ptype_abstract ->
          (match td.ptype_manifest with
           | None -> sexp_of_nil loc
           | Some ty -> sexp_of_type ~renaming ty)
          |> Lifted.return
      in
      body
      >>| fun body ->
      let is_private_alias =
        match td.ptype_kind, td.ptype_manifest, td.ptype_private with
        | Ptype_abstract, Some _, Private -> true
        | _ -> false
      in
      if is_private_alias
      then (
        (* Replace all type variable by _ to avoid generalization problems *)
        let ty_src =
          core_type_of_type_declaration td |> replace_variables_by_underscores
        in
        let manifest =
          match td.ptype_manifest with
          | Some manifest -> manifest
          | None -> Location.raise_errorf ~loc "sexp_of_td/no-manifest"
        in
        let ty_dst = replace_variables_by_underscores manifest in
        let v = Fresh_name.create "v" ~loc in
        let coercion =
          [%expr ([%e Fresh_name.expression v] : [%t ty_src] :> [%t ty_dst])]
        in
        [%expr fun [%p Fresh_name.pattern v] -> [%e Conversion.apply ~loc body coercion]])
      else
        (* Prevent violation of value restriction, problems with recursive types, and
           top-level effects by eta-expanding function definitions *)
        Conversion.to_value_expression
          ~loc
          ~rec_flag:(Types_being_defined.to_rec_flag types_being_defined)
          ~values_being_defined:
            (Types_being_defined.to_values_being_defined types_being_defined)
          body
    in
    let typ = Sig_generate_sexp_of.mk_type td in
    let func_name = "sexp_of_" ^ type_name in
    let body =
      body
      >>| fun body ->
      let patts =
        List.map tps ~f:(fun id ->
          match Renaming.binding_kind renaming id.txt ~loc:id.loc with
          | Universally_bound name -> Fresh_name.pattern name
          | Existentially_bound -> assert false)
      in
      let rec_flag = Types_being_defined.to_rec_flag types_being_defined in
      eta_reduce_if_possible_and_nonrec ~rec_flag (eabstract ~loc patts body)
    in
    let body = Lifted.let_bind_user_expressions ~loc body in
    constrained_function_binding loc td typ ~tps ~func_name body
  ;;

  let sexp_of_tds ~loc ~path:_ (rec_flag, tds) =
    let rec_flag = really_recursive_respecting_opaque rec_flag tds in
    let (types_being_defined : Types_being_defined.t) =
      match rec_flag with
      | Nonrecursive -> Nonrec
      | Recursive ->
        Rec (Set.of_list (module String) (List.map tds ~f:(fun td -> td.ptype_name.txt)))
    in
    let bindings = List.map tds ~f:(sexp_of_td ~types_being_defined) in
    pstr_value_list ~loc rec_flag bindings
  ;;

  let sexp_of_exn ~loc:_ ~path ec =
    let renaming = Renaming.without_type () in
    let get_full_cnstr str = path ^ "." ^ str in
    let loc = ec.ptyexn_loc in
    let expr =
      match ec.ptyexn_constructor with
      | { pext_name = cnstr
        ; pext_kind = Pext_decl (_, extension_constructor_kind, None)
        ; _
        } ->
        let constr_lid = Located.map lident cnstr in
        branch_sum
          ec
          Attrs.list_exception
          ~types_being_defined:Nonrec
          renaming
          ~loc
          constr_lid
          (estring ~loc (get_full_cnstr cnstr.txt))
          extension_constructor_kind
        >>| fun converter ->
        let assert_false = ppat_any ~loc --> [%expr assert false] in
        [%expr
          Sexplib0.Sexp_conv.Exn_converter.add
            [%extension_constructor [%e pexp_construct ~loc constr_lid None]]
            [%e
              Conversion.to_expression
                ~loc
                (Conversion.of_lambda [ converter; assert_false ])]]
      | { pext_kind = Pext_decl (_, _, Some _); _ } ->
        Location.raise_errorf ~loc "sexp_of_exn/:"
      | { pext_kind = Pext_rebind _; _ } ->
        Location.raise_errorf ~loc "sexp_of_exn/rebind"
    in
    let expr = Lifted.let_bind_user_expressions ~loc expr in
    [ pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat:[%pat? ()] ~expr ] ]
  ;;

  let sexp_of_core_type core_type =
    let loc = { core_type.ptyp_loc with loc_ghost = true } in
    sexp_of_type ~renaming:(Renaming.without_type ()) core_type
    |> Conversion.to_value_expression
         ~loc
         ~rec_flag:Nonrecursive
         ~values_being_defined:(Set.empty (module String))
    |> Merlin_helpers.hide_expression
  ;;
end