unikernel/duniverse/ppx_sexp_conv/expander/attrs.ml

@@ -0,0 +1,232 @@
+open! Base
+open! Ppxlib
+
+module To_lift = struct
+  type 'a t = { to_lift : 'a } [@@unboxed]
+end
+
+open To_lift
+
+let default =
+  Attribute.declare
+    "sexp.default"
+    Attribute.Context.label_declaration
+    Ast_pattern.(pstr (pstr_eval __ nil ^:: nil))
+    (fun x -> { to_lift = x })
+;;
+
+let drop_default =
+  Attribute.declare
+    "sexp.sexp_drop_default"
+    Attribute.Context.label_declaration
+    Ast_pattern.(pstr (alt_option (pstr_eval __ nil ^:: nil) nil))
+    (function
+     | None -> None
+     | Some x -> Some { to_lift = x })
+;;
+
+let drop_default_equal =
+  Attribute.declare
+    "sexp.@sexp_drop_default.equal"
+    Attribute.Context.label_declaration
+    Ast_pattern.(pstr nil)
+    ()
+;;
+
+let drop_default_compare =
+  Attribute.declare
+    "sexp.@sexp_drop_default.compare"
+    Attribute.Context.label_declaration
+    Ast_pattern.(pstr nil)
+    ()
+;;
+
+let drop_default_sexp =
+  Attribute.declare
+    "sexp.@sexp_drop_default.sexp"
+    Attribute.Context.label_declaration
+    Ast_pattern.(pstr nil)
+    ()
+;;
+
+let drop_if =
+  Attribute.declare
+    "sexp.sexp_drop_if"
+    Attribute.Context.label_declaration
+    Ast_pattern.(pstr (pstr_eval __ nil ^:: nil))
+    (fun x -> { to_lift = x })
+;;
+
+let opaque =
+  Attribute.declare "sexp.opaque" Attribute.Context.core_type Ast_pattern.(pstr nil) ()
+;;
+
+let omit_nil =
+  Attribute.declare
+    "sexp.omit_nil"
+    Attribute.Context.label_declaration
+    Ast_pattern.(pstr nil)
+    ()
+;;
+
+let option =
+  Attribute.declare
+    "sexp.option"
+    Attribute.Context.label_declaration
+    Ast_pattern.(pstr nil)
+    ()
+;;
+
+let list =
+  Attribute.declare
+    "sexp.list"
+    Attribute.Context.label_declaration
+    Ast_pattern.(pstr nil)
+    ()
+;;
+
+let array =
+  Attribute.declare
+    "sexp.array"
+    Attribute.Context.label_declaration
+    Ast_pattern.(pstr nil)
+    ()
+;;
+
+let bool =
+  Attribute.declare
+    "sexp.bool"
+    Attribute.Context.label_declaration
+    Ast_pattern.(pstr nil)
+    ()
+;;
+
+let list_variant =
+  Attribute.declare
+    "sexp.list"
+    Attribute.Context.constructor_declaration
+    Ast_pattern.(pstr nil)
+    ()
+;;
+
+let list_exception =
+  Attribute.declare "sexp.list" Attribute.Context.type_exception Ast_pattern.(pstr nil) ()
+;;
+
+let list_poly =
+  Attribute.declare "sexp.list" Attribute.Context.rtag Ast_pattern.(pstr nil) ()
+;;
+
+let allow_extra_fields_td =
+  Attribute.declare
+    "sexp.allow_extra_fields"
+    Attribute.Context.type_declaration
+    Ast_pattern.(pstr nil)
+    ()
+;;
+
+let allow_extra_fields_cd =
+  Attribute.declare
+    "sexp.allow_extra_fields"
+    Attribute.Context.constructor_declaration
+    Ast_pattern.(pstr nil)
+    ()
+;;
+
+let grammar_custom =
+  Attribute.declare
+    "sexp_grammar.custom"
+    Attribute.Context.core_type
+    Ast_pattern.(single_expr_payload __)
+    (fun x -> x)
+;;
+
+let grammar_any =
+  Attribute.declare
+    "sexp_grammar.any"
+    Attribute.Context.core_type
+    Ast_pattern.(alt_option (single_expr_payload (estring __)) (pstr nil))
+    (fun x -> x)
+;;
+
+let tag_attribute_for_context context =
+  let open Ast_pattern in
+  let key_equals_value =
+    Ast_pattern.(
+      pexp_apply (pexp_ident (lident (string "="))) (no_label __ ^:: no_label __ ^:: nil)
+      |> pack2)
+  in
+  let get_captured_values ast_pattern context expression =
+    Ast_pattern.to_func ast_pattern context expression.pexp_loc expression (fun x -> x)
+  in
+  let rec collect_sequence expression =
+    match expression.pexp_desc with
+    | Pexp_sequence (l, r) -> l :: collect_sequence r
+    | _ -> [ expression ]
+  in
+  let esequence ast_pattern =
+    Ast_pattern.of_func (fun context _loc expression k ->
+      collect_sequence expression
+      |> List.map ~f:(get_captured_values ast_pattern context)
+      |> k)
+  in
+  Attribute.declare
+    "sexp_grammar.tag"
+    context
+    (pstr (pstr_eval (esequence key_equals_value) nil ^:: nil))
+    (fun x -> x)
+;;
+
+let tag_type = tag_attribute_for_context Core_type
+let tag_ld = tag_attribute_for_context Label_declaration
+let tag_cd = tag_attribute_for_context Constructor_declaration
+let tag_poly = tag_attribute_for_context Rtag
+
+let tags_attribute_for_context context =
+  Attribute.declare
+    "sexp_grammar.tags"
+    context
+    Ast_pattern.(single_expr_payload __)
+    (fun x -> x)
+;;
+
+let tags_type = tags_attribute_for_context Core_type
+let tags_ld = tags_attribute_for_context Label_declaration
+let tags_cd = tags_attribute_for_context Constructor_declaration
+let tags_poly = tags_attribute_for_context Rtag
+
+let invalid_attribute ~loc attr description =
+  Location.raise_errorf
+    ~loc
+    "ppx_sexp_conv: [@%s] is only allowed on type [%s]."
+    (Attribute.name attr)
+    description
+;;
+
+let fail_if_allow_extra_field_cd ~loc x =
+  if Option.is_some (Attribute.get allow_extra_fields_cd x)
+  then
+    Location.raise_errorf
+      ~loc
+      "ppx_sexp_conv: [@@allow_extra_fields] is only allowed on inline records."
+;;
+
+let fail_if_allow_extra_field_td ~loc x =
+  if Option.is_some (Attribute.get allow_extra_fields_td x)
+  then (
+    match x.ptype_kind with
+    | Ptype_variant cds
+      when List.exists cds ~f:(fun cd ->
+             match cd.pcd_args with
+             | Pcstr_record _ -> true
+             | _ -> false) ->
+      Location.raise_errorf
+        ~loc
+        "ppx_sexp_conv: [@@@@allow_extra_fields] only works on records. For inline \
+         records, do: type t = A of { a : int } [@@allow_extra_fields] | B [@@@@deriving \
+         sexp]"
+    | _ ->
+      Location.raise_errorf
+        ~loc
+        "ppx_sexp_conv: [@@@@allow_extra_fields] is only allowed on records.")
+;;

unikernel/duniverse/ppx_sexp_conv/expander/attrs.mli

@@ -0,0 +1,40 @@
+open! Base
+open! Ppxlib
+
+(** [default], [drop_default], and [drop_if] attributes are annotated with expressions
+    that should be lifted out of the scope of ppx-generated temporary variables. See the
+    [Lifted] module. *)
+module To_lift : sig
+  type 'a t = { to_lift : 'a } [@@unboxed]
+end
+
+val default : (label_declaration, expression To_lift.t) Attribute.t
+val drop_default : (label_declaration, expression To_lift.t option) Attribute.t
+val drop_if : (label_declaration, expression To_lift.t) Attribute.t
+val drop_default_equal : (label_declaration, unit) Attribute.t
+val drop_default_compare : (label_declaration, unit) Attribute.t
+val drop_default_sexp : (label_declaration, unit) Attribute.t
+val omit_nil : (label_declaration, unit) Attribute.t
+val option : (label_declaration, unit) Attribute.t
+val list : (label_declaration, unit) Attribute.t
+val array : (label_declaration, unit) Attribute.t
+val bool : (label_declaration, unit) Attribute.t
+val opaque : (core_type, unit) Attribute.t
+val list_variant : (constructor_declaration, unit) Attribute.t
+val list_exception : (type_exception, unit) Attribute.t
+val list_poly : (row_field, unit) Attribute.t
+val allow_extra_fields_td : (type_declaration, unit) Attribute.t
+val allow_extra_fields_cd : (constructor_declaration, unit) Attribute.t
+val invalid_attribute : loc:Location.t -> (_, _) Attribute.t -> string -> 'a
+val fail_if_allow_extra_field_cd : loc:Location.t -> constructor_declaration -> unit
+val fail_if_allow_extra_field_td : loc:Location.t -> type_declaration -> unit
+val grammar_any : (core_type, string option) Attribute.t
+val grammar_custom : (core_type, expression) Attribute.t
+val tag_type : (core_type, (expression * expression) list) Attribute.t
+val tag_ld : (label_declaration, (expression * expression) list) Attribute.t
+val tag_cd : (constructor_declaration, (expression * expression) list) Attribute.t
+val tag_poly : (row_field, (expression * expression) list) Attribute.t
+val tags_type : (core_type, expression) Attribute.t
+val tags_ld : (label_declaration, expression) Attribute.t
+val tags_cd : (constructor_declaration, expression) Attribute.t
+val tags_poly : (row_field, expression) Attribute.t

unikernel/duniverse/ppx_sexp_conv/expander/conversion.ml

@@ -0,0 +1,184 @@
+open! Base
+open! Ppxlib
+open Ast_builder.Default
+open Helpers
+
+module Reference = struct
+  type t =
+    { types : type_declaration list
+    ; binds : value_binding list list
+    ; ident : longident_loc
+    ; args : (arg_label * expression) list
+    }
+
+  let bind t binds = { t with binds = binds :: t.binds }
+  let bind_types t types = { t with types = types @ t.types }
+
+  let maybe_apply { types; binds; ident; args } ~loc maybe_arg =
+    let ident = pexp_ident ~loc ident in
+    let args =
+      match maybe_arg with
+      | None -> args
+      | Some arg -> args @ [ Nolabel, arg ]
+    in
+    let expr =
+      match args with
+      | [] -> ident
+      | _ -> pexp_apply ~loc ident args
+    in
+    with_types ~loc ~types (with_let ~loc ~binds expr)
+  ;;
+
+  let apply t ~loc arg = maybe_apply t ~loc (Some arg)
+  let to_expression t ~loc = maybe_apply t ~loc None
+
+  let to_value_expression t ~loc ~rec_flag ~values_being_defined =
+    let may_refer_directly_to ident =
+      match rec_flag with
+      | Nonrecursive -> true
+      | Recursive -> not (Set.mem values_being_defined (Longident.name ident.txt))
+    in
+    match t with
+    | { types = []; binds = []; ident; args = [] } when may_refer_directly_to ident ->
+      pexp_ident ~loc ident
+    | _ -> fresh_lambda ~loc (fun ~arg -> apply t ~loc arg)
+  ;;
+end
+
+module Lambda = struct
+  type t =
+    { types : type_declaration list
+    ; binds : value_binding list list
+    ; cases : cases
+    }
+
+  let bind t binds = { t with binds = binds :: t.binds }
+  let bind_types t types = { t with types = types @ t.types }
+
+  (* generic case: use [function] or [match] *)
+  let maybe_apply_generic ~loc ~types ~binds maybe_arg cases =
+    let expr =
+      match maybe_arg with
+      | None -> pexp_function_cases ~loc cases
+      | Some arg -> pexp_match ~loc arg cases
+    in
+    with_types ~loc ~types (with_let ~loc ~binds expr)
+  ;;
+
+  (* zero cases: synthesize an "impossible" case, i.e. [| _ -> .] *)
+  let maybe_apply_impossible ~loc ~types ~binds maybe_arg =
+    [ case ~lhs:(ppat_any ~loc) ~guard:None ~rhs:(pexp_unreachable ~loc) ]
+    |> maybe_apply_generic ~loc ~binds ~types maybe_arg
+  ;;
+
+  (* one case without guard: use [fun] or [let] *)
+  let maybe_apply_simple ~loc ~types ~binds maybe_arg pat body =
+    let expr =
+      match maybe_arg with
+      | None -> pexp_fun ~loc Nolabel None pat body
+      | Some arg -> pexp_let ~loc Nonrecursive [ value_binding ~loc ~pat ~expr:arg ] body
+    in
+    with_types ~loc ~types (with_let ~loc ~binds expr)
+  ;;
+
+  (* shared special-casing logic for [apply] and [to_expression] *)
+  let maybe_apply t ~loc maybe_arg =
+    match t with
+    | { types; binds; cases = [] } -> maybe_apply_impossible ~loc ~types ~binds maybe_arg
+    | { types; binds; cases = [ { pc_lhs; pc_guard = None; pc_rhs } ] } ->
+      maybe_apply_simple ~loc ~types ~binds maybe_arg pc_lhs pc_rhs
+    | { types; binds; cases } -> maybe_apply_generic ~loc ~types ~binds maybe_arg cases
+  ;;
+
+  let apply t ~loc arg = maybe_apply t ~loc (Some arg)
+  let to_expression t ~loc = maybe_apply t ~loc None
+
+  let to_value_expression t ~loc =
+    match t with
+    | { types = []; binds = []; cases = _ } ->
+      (* lambdas without [let] are already values *)
+      let expr = to_expression t ~loc in
+      assert (is_value_expression expr);
+      expr
+    | _ -> fresh_lambda ~loc (fun ~arg -> apply t ~loc arg)
+  ;;
+end
+
+type t =
+  | Reference of Reference.t
+  | Lambda of Lambda.t
+
+let of_lambda cases = Lambda { types = []; binds = []; cases }
+
+let of_reference_exn expr =
+  match expr.pexp_desc with
+  | Pexp_ident ident -> Reference { types = []; binds = []; ident; args = [] }
+  | Pexp_apply ({ pexp_desc = Pexp_ident ident; _ }, args) ->
+    Reference { types = []; binds = []; ident; args }
+  | _ ->
+    Location.raise_errorf
+      ~loc:expr.pexp_loc
+      "ppx_sexp_conv: internal error.\n\
+       [Conversion.of_reference_exn] expected an identifier possibly applied to arguments.\n\
+       Instead, got:\n\
+       %s"
+      (Pprintast.string_of_expression expr)
+;;
+
+let to_expression t ~loc =
+  match t with
+  | Reference reference -> Reference.to_expression ~loc reference
+  | Lambda lambda -> Lambda.to_expression ~loc lambda
+;;
+
+let to_value_expression t ~loc ~rec_flag ~values_being_defined =
+  match t with
+  | Reference reference ->
+    Reference.to_value_expression ~loc ~rec_flag ~values_being_defined reference
+  | Lambda lambda -> Lambda.to_value_expression ~loc lambda
+;;
+
+let apply t ~loc e =
+  match t with
+  | Reference reference -> Reference.apply ~loc reference e
+  | Lambda lambda -> Lambda.apply ~loc lambda e
+;;
+
+let bind t binds =
+  match t with
+  | Reference reference -> Reference (Reference.bind reference binds)
+  | Lambda lambda -> Lambda (Lambda.bind lambda binds)
+;;
+
+let bind_types t types =
+  match t with
+  | Reference reference -> Reference (Reference.bind_types reference types)
+  | Lambda lambda -> Lambda (Lambda.bind_types lambda types)
+;;
+
+module Apply_all = struct
+  type t =
+    { bindings : value_binding list
+    ; arguments : pattern list
+    ; converted : expression list
+    }
+end
+
+let gen_symbols list ~prefix =
+  List.mapi list ~f:(fun i _ -> gen_symbol ~prefix:(prefix ^ Int.to_string i) ())
+;;
+
+let apply_all ts ~loc =
+  let arguments_names = gen_symbols ts ~prefix:"arg" in
+  let converted_names = gen_symbols ts ~prefix:"res" in
+  let bindings =
+    List.map3_exn ts arguments_names converted_names ~f:(fun t arg conv ->
+      let expr = apply ~loc t (evar ~loc arg) in
+      value_binding ~loc ~pat:(pvar ~loc conv) ~expr)
+  in
+  ({ bindings
+   ; arguments = List.map arguments_names ~f:(pvar ~loc)
+   ; converted = List.map converted_names ~f:(evar ~loc)
+   }
+    : Apply_all.t)
+;;

unikernel/duniverse/ppx_sexp_conv/expander/conversion.mli

@@ -0,0 +1,53 @@
+open! Base
+open! Ppxlib
+
+(** Sexp conversion function, expressed as either a single expression or as a collection
+    of [match] cases. Expressing as cases rather than wrapping directly in [pexp_function_cases]
+    allows us to simplify some expressions built on this. *)
+type t
+
+(** Construct [t] from a list of pattern/expression cases. *)
+val of_lambda : cases -> t
+
+(** Construct [t] from an identifier, possibly applied to arguments. Raise on any other
+    form of expression. *)
+val of_reference_exn : expression -> t
+
+(** Convert [t] to an expression. *)
+val to_expression : t -> loc:location -> expression
+
+(** Convert [t] to an expression that is a syntactic value, i.e. a constant, identifier,
+    or lambda expression that does no "work", can can be preallocated, and works in the
+    context of a [let rec]. *)
+val to_value_expression
+  :  t
+  -> loc:location
+  -> rec_flag:rec_flag
+  -> values_being_defined:Set.M(String).t
+  -> expression
+
+(** Apply [t] to an argument. *)
+val apply
+  :  t
+  -> loc:location
+  -> expression (** argument [t] is applied to *)
+  -> expression
+
+(** Wrap [t] in [let]-bindings. *)
+val bind : t -> value_binding list -> t
+
+(** Wrap [t] in [let open .. in] with type declarations. *)
+val bind_types : t -> type_declaration list -> t
+
+module Apply_all : sig
+  type t =
+    { bindings : value_binding list
+    ; arguments : pattern list
+    ; converted : expression list
+    }
+end
+
+(** Applies each [t] to a fresh variable, and binds the results to fresh variables.
+    Returns the corresponding [value_binding]s, patterns for the argument variables, and
+    expressions for the result variables. *)
+val apply_all : t list -> loc:location -> Apply_all.t

unikernel/duniverse/ppx_sexp_conv/expander/dune

@@ -0,0 +1,8 @@
+(library
+ (name ppx_sexp_conv_expander)
+ (public_name ppx_sexp_conv.expander)
+ (libraries base compiler-libs.common ppxlib ppxlib_jane
+   ppxlib.metaquot_lifters)
+ (ppx_runtime_libraries ppx_sexp_conv.runtime-lib sexplib0)
+ (preprocess
+  (pps ppxlib.metaquot ppxlib.traverse)))

unikernel/duniverse/ppx_sexp_conv/expander/expand_of_sexp.mli

@@ -0,0 +1,28 @@
+open! Base
+open! Ppxlib
+
+module Sig_generate_of_sexp : sig
+  (** Given a type, produce the type of its [of_sexp] conversion. *)
+  val type_of_of_sexp : loc:location -> core_type -> core_type
+
+  (** Derive an [of_sexp] interface for a list of type declarations. *)
+  val mk_sig
+    :  poly:bool
+    -> loc:location
+    -> path:string
+    -> rec_flag * type_declaration list
+    -> signature_item list
+end
+
+module Str_generate_of_sexp : sig
+  (** Given a type, produce its [of_sexp] conversion. *)
+  val core_type_of_sexp : path:string -> core_type -> expression
+
+  (** Derive an [of_sexp] implementation for a list of type declarations. *)
+  val tds_of_sexp
+    :  loc:location
+    -> poly:bool
+    -> path:string
+    -> rec_flag * type_declaration list
+    -> structure_item list
+end

unikernel/duniverse/ppx_sexp_conv/expander/expand_sexp_of.ml

@@ -0,0 +1,822 @@
+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 _; _ }
+       | { ptyp_desc = Ptyp_open _; _ } ->
+         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

unikernel/duniverse/ppx_sexp_conv/expander/expand_sexp_of.mli

@@ -0,0 +1,32 @@
+open! Base
+open! Ppxlib
+
+module Sig_generate_sexp_of : sig
+  (** Given a type, produce the type of its [sexp_of] conversion. *)
+  val type_of_sexp_of : loc:location -> core_type -> core_type
+
+  (** Derive a [sexp_of] interface for a list of type declarations. *)
+  val mk_sig
+    :  loc:location
+    -> path:string
+    -> rec_flag * type_declaration list
+    -> signature_item list
+
+  (** Derive a [sexp_of] interface for an exception declaration. *)
+  val mk_sig_exn : loc:location -> path:string -> type_exception -> signature_item list
+end
+
+module Str_generate_sexp_of : sig
+  (** Given a type, produce its [sexp_of] conversion. *)
+  val sexp_of_core_type : core_type -> expression
+
+  (** Derive a [sexp_of] implementation for a list of type declarations. *)
+  val sexp_of_tds
+    :  loc:location
+    -> path:string
+    -> rec_flag * type_declaration list
+    -> structure_item list
+
+  (** Derive a [sexp_of] implementation for an exception declaration. *)
+  val sexp_of_exn : loc:location -> path:string -> type_exception -> structure_item list
+end

unikernel/duniverse/ppx_sexp_conv/expander/fresh_name.ml

@@ -0,0 +1,14 @@
+open! Base
+open Ppxlib
+open Ast_builder.Default
+
+type t =
+  { loc : location
+  ; unique_name : string
+  }
+
+let create string ~loc = { loc; unique_name = gen_symbol ~prefix:string () }
+let of_string_loc { loc; txt } = create txt ~loc
+let to_string_loc { loc; unique_name } = { loc; txt = unique_name }
+let expression { loc; unique_name } = evar unique_name ~loc
+let pattern { loc; unique_name } = pvar unique_name ~loc

unikernel/duniverse/ppx_sexp_conv/expander/fresh_name.mli

@@ -0,0 +1,21 @@
+(** Represents freshly generated names at ppx expansion time. *)
+
+open! Base
+open Ppxlib
+
+type t
+
+(** Creates a new fresh name using the given string as a prefix. *)
+val create : string -> loc:location -> t
+
+(** [of_string_loc { loc; txt }] is equivalent to [create txt ~loc] *)
+val of_string_loc : string loc -> t
+
+(** Extracts the freshly created name and its location. *)
+val to_string_loc : t -> string loc
+
+(** Constructs an expression referring to the fresh name. *)
+val expression : t -> expression
+
+(** Constructs a pattern binding the fresh name. *)
+val pattern : t -> pattern

unikernel/duniverse/ppx_sexp_conv/expander/helpers.ml

@@ -0,0 +1,253 @@
+open! Base
+open! Ppxlib
+open Ast_builder.Default
+
+let ( --> ) lhs rhs = case ~guard:None ~lhs ~rhs
+
+(* Utility functions *)
+
+let replace_variables_by_underscores =
+  let map =
+    object
+      inherit Ast_traverse.map as super
+
+      method! core_type_desc =
+        function
+        | Ptyp_var _ -> Ptyp_any
+        | t -> super#core_type_desc t
+    end
+  in
+  map#core_type
+;;
+
+let make_rigid_types tps =
+  List.fold
+    tps
+    ~init:(Map.empty (module String))
+    ~f:(fun map tp ->
+      Map.update map tp.txt ~f:(function
+        | None -> Fresh_name.of_string_loc tp
+        | Some fresh ->
+          (* Ignore duplicate names, the typechecker will raise after expansion. *)
+          fresh))
+;;
+
+let find_rigid_type ~loc ~rigid_types name =
+  match Map.find rigid_types name with
+  | Some tp -> Fresh_name.to_string_loc tp
+  | None ->
+    (* Ignore unbound type names, the typechecker will raise after expansion. *)
+    { txt = name; loc }
+;;
+
+let make_type_rigid ~rigid_types =
+  let map =
+    object
+      inherit Ast_traverse.map as super
+
+      method! core_type ty =
+        let ptyp_desc =
+          match ty.ptyp_desc with
+          | Ptyp_var s ->
+            Ptyp_constr
+              (Located.map_lident (find_rigid_type ~loc:ty.ptyp_loc ~rigid_types s), [])
+          | desc -> super#core_type_desc desc
+        in
+        { ty with ptyp_desc }
+    end
+  in
+  map#core_type
+;;
+
+(* Generates the quantified type [ ! 'a .. 'z . (make_mono_type t ('a .. 'z)) ] or
+   [type a .. z. make_mono_type t (a .. z)] when [use_rigid_variables] is true.
+   Annotation are needed for non regular recursive datatypes and gadt when the return type
+   of constructors are constrained. Unfortunately, putting rigid variables everywhere does
+   not work because of certains types with constraints. We thus only use rigid variables
+   for sum types, which includes all GADTs. *)
+
+let tvars_of_core_type : core_type -> string list =
+  let tvars =
+    object
+      inherit [string list] Ast_traverse.fold as super
+
+      method! core_type x acc =
+        match x.ptyp_desc with
+        | Ptyp_var x -> if List.mem acc x ~equal:String.equal then acc else x :: acc
+        | _ -> super#core_type x acc
+    end
+  in
+  fun typ -> List.rev (tvars#core_type typ [])
+;;
+
+let constrained_function_binding
+  (* placing a suitably polymorphic or rigid type constraint on the pattern or body *)
+    (loc : Location.t)
+  (td : type_declaration)
+  (typ : core_type)
+  ~(tps : string loc list)
+  ~(func_name : string)
+  (body : expression)
+  =
+  let vars = tvars_of_core_type typ in
+  let has_vars =
+    match vars with
+    | [] -> false
+    | _ :: _ -> true
+  in
+  let pat =
+    let pat = pvar ~loc func_name in
+    if not has_vars
+    then pat
+    else (
+      let vars = List.map ~f:(fun txt -> { txt; loc }) vars in
+      ppat_constraint ~loc pat (ptyp_poly ~loc vars typ))
+  in
+  let body =
+    let use_rigid_variables =
+      match td.ptype_kind with
+      | Ptype_variant _ -> true
+      | _ -> false
+    in
+    if use_rigid_variables
+    then (
+      let rigid_types = make_rigid_types tps in
+      List.fold_right
+        tps
+        ~f:(fun tp body ->
+          pexp_newtype ~loc (find_rigid_type ~loc:tp.loc ~rigid_types tp.txt) body)
+        ~init:(pexp_constraint ~loc body (make_type_rigid ~rigid_types typ)))
+    else if has_vars
+    then body
+    else pexp_constraint ~loc body typ
+  in
+  value_binding ~loc ~pat ~expr:body
+;;
+
+let with_let ~loc ~binds body =
+  List.fold_right binds ~init:body ~f:(fun bind body ->
+    if List.is_empty bind then body else pexp_let ~loc Nonrecursive bind body)
+;;
+
+let with_types ~loc ~types body =
+  if List.is_empty types
+  then body
+  else
+    pexp_open
+      ~loc
+      (open_infos
+         ~loc
+         ~override:Fresh
+         ~expr:
+           (pmod_structure
+              ~loc
+              (List.map types ~f:(fun type_decl -> pstr_type ~loc Recursive [ type_decl ]))))
+      body
+;;
+
+let fresh_lambda ~loc apply =
+  let var = gen_symbol ~prefix:"x" () in
+  let pat = pvar ~loc var in
+  let arg = evar ~loc var in
+  let body = apply ~arg in
+  pexp_fun ~loc Nolabel None pat body
+;;
+
+let rec is_value_expression expr =
+  match expr.pexp_desc with
+  (* Syntactic values. *)
+  | Pexp_ident _ | Pexp_constant _ | Pexp_function _ | Pexp_lazy _ -> true
+  (* Type-only wrappers; we check their contents. *)
+  | Pexp_constraint (expr, (_ : core_type))
+  | Pexp_coerce (expr, (_ : core_type option), (_ : core_type))
+  | Pexp_newtype ((_ : string loc), expr) -> is_value_expression expr
+  (* Allocating constructors; they are only values if all of their contents are. *)
+  | Pexp_tuple exprs -> List.for_all exprs ~f:is_value_expression
+  | Pexp_construct (_, maybe_expr) -> Option.for_all maybe_expr ~f:is_value_expression
+  | Pexp_variant (_, maybe_expr) -> Option.for_all maybe_expr ~f:is_value_expression
+  | Pexp_record (fields, maybe_expr) ->
+    List.for_all fields ~f:(fun (_, expr) -> is_value_expression expr)
+    && Option.for_all maybe_expr ~f:is_value_expression
+  (* Not values, or not always values. We make a conservative approximation. *)
+  | Pexp_unreachable
+  | Pexp_let _
+  | Pexp_apply _
+  | Pexp_match _
+  | Pexp_try _
+  | Pexp_field _
+  | Pexp_setfield _
+  | Pexp_array _
+  | Pexp_ifthenelse _
+  | Pexp_sequence _
+  | Pexp_while _
+  | Pexp_for _
+  | Pexp_send _
+  | Pexp_new _
+  | Pexp_setinstvar _
+  | Pexp_override _
+  | Pexp_letmodule _
+  | Pexp_letexception _
+  | Pexp_assert _
+  | Pexp_poly _
+  | Pexp_object _
+  | Pexp_pack _
+  | Pexp_open _
+  | Pexp_letop _
+  | Pexp_extension _ -> false
+;;
+
+let really_recursive_respecting_opaque rec_flag tds =
+  (object
+     inherit type_is_recursive rec_flag tds as super
+
+     method! core_type ctype =
+       match ctype with
+       | _ when Option.is_some (Attribute.get ~mark_as_seen:false Attrs.opaque ctype) ->
+         ()
+       | [%type: [%t? _] sexp_opaque] -> ()
+       | _ -> super#core_type ctype
+  end)
+    #go
+    ()
+;;
+
+let strip_attributes =
+  object
+    inherit Ast_traverse.map
+
+    method! attribute attr =
+      Location.raise_errorf ~loc:attr.attr_loc "failed to strip attribute from syntax"
+
+    method! attributes _ = []
+
+    method! signature items =
+      List.filter items ~f:(fun item ->
+        match item.psig_desc with
+        | Psig_attribute _ -> false
+        | _ -> true)
+
+    method! structure items =
+      List.filter items ~f:(fun item ->
+        match item.pstr_desc with
+        | Pstr_attribute _ -> false
+        | _ -> true)
+
+    method! class_signature csig =
+      { csig with
+        pcsig_fields =
+          List.filter csig.pcsig_fields ~f:(fun field ->
+            match field.pctf_desc with
+            | Pctf_attribute _ -> false
+            | _ -> true)
+      }
+
+    method! class_structure cstr =
+      { cstr with
+        pcstr_fields =
+          List.filter cstr.pcstr_fields ~f:(fun field ->
+            match field.pcf_desc with
+            | Pcf_attribute _ -> false
+            | _ -> true)
+      }
+  end
+;;

unikernel/duniverse/ppx_sexp_conv/expander/helpers.mli

@@ -0,0 +1,41 @@
+open! Base
+open! Ppxlib
+
+(** Constructs a branch of a [match] or [function] expression with no guard. *)
+val ( --> ) : pattern -> expression -> case
+
+(** Replace all type variables like ['a] with wildcard ([_]) types. *)
+val replace_variables_by_underscores : core_type -> core_type
+
+(** Create a binding for a derived function, adding a type annotation if required. *)
+val constrained_function_binding
+  :  location (** location to use for the binding *)
+  -> type_declaration (** type declaration used to derive the function *)
+  -> core_type (** type of the function *)
+  -> tps:string loc list (** names of type parameters in the declaration *)
+  -> func_name:string (** name to bind the function to *)
+  -> expression (** expression representing the function *)
+  -> value_binding
+
+(** Wraps an expression in layers of non-recursive [let] bindings, with the bindings
+    sorted from outermost to innermost. *)
+val with_let : loc:location -> binds:value_binding list list -> expression -> expression
+
+(** Wraps an expression in [let open] containing type declarations, if non-empty. *)
+val with_types : loc:location -> types:type_declaration list -> expression -> expression
+
+(** Constructs a lambda of a fresh variable. Passes a reference to that variable as [arg]
+    to construct the lambda's body. *)
+val fresh_lambda : loc:location -> (arg:expression -> expression) -> expression
+
+(** Conservative approximation of which expressions are syntactically values, i.e.
+    constants, variables, or lambdas. When [true], these expressions have no effects
+    (other than possibly closure allocation) and can be used in [let rec] definitions.
+    When [false], they may need to be eta-expanded or wrapped in [lazy]. *)
+val is_value_expression : expression -> bool
+
+(** Shadows [Ppxlib.really_recursive] with a version that respects the [[@opaque]]
+    attribute. *)
+val really_recursive_respecting_opaque : rec_flag -> type_declaration list -> rec_flag
+
+val strip_attributes : Ast_traverse.map

unikernel/duniverse/ppx_sexp_conv/expander/labeled_tuple.ml

@@ -0,0 +1,8 @@
+open! Base
+
+let is_valid alist = List.exists alist ~f:(fun (option, _) -> Option.is_some option)
+
+let atom_of_label = function
+  | None -> "."
+  | Some string -> "~" ^ string
+;;

unikernel/duniverse/ppx_sexp_conv/expander/labeled_tuple.mli

@@ -0,0 +1,9 @@
+(* Support for labeled tuples, a language feature currently only implemented in Jane
+   Street's experimental branch of the compiler
+   (https://github.com/ocaml-flambda/flambda-backend/). *)
+
+open! Base
+open Ppxlib_jane
+
+val is_valid : Jane_syntax.Labeled_tuples.core_type -> bool
+val atom_of_label : string option -> string

unikernel/duniverse/ppx_sexp_conv/expander/lifted.ml

@@ -0,0 +1,46 @@
+open! Base
+open Ppxlib
+open Ast_builder.Default
+
+type 'a t =
+  { value_bindings : value_binding list
+  ; body : 'a
+  }
+
+include Monad.Make (struct
+  type nonrec 'a t = 'a t
+
+  let return body = { value_bindings = []; body }
+
+  let bind a ~f =
+    let b = f a.body in
+    { value_bindings = a.value_bindings @ b.value_bindings; body = b.body }
+  ;;
+
+  let map = `Define_using_bind
+end)
+
+let create ~loc ~prefix ~ty rhs =
+  let name = gen_symbol ~prefix () in
+  let lhs = pvar ~loc name in
+  let body = evar ~loc name in
+  let ty, rhs, body =
+    if Helpers.is_value_expression rhs
+    then ty, rhs, body
+    else (
+      (* Thunkify the value to evaluate when referred to. *)
+      let ty = [%type: Stdlib.Unit.t -> [%t ty]] in
+      let rhs = [%expr fun () -> [%e rhs]] in
+      let body = [%expr [%e body] ()] in
+      ty, rhs, body)
+  in
+  { value_bindings = [ value_binding ~loc ~pat:(ppat_constraint ~loc lhs ty) ~expr:rhs ]
+  ; body
+  }
+;;
+
+let let_bind_user_expressions { value_bindings; body } ~loc =
+  if List.is_empty value_bindings
+  then body
+  else pexp_let ~loc Nonrecursive value_bindings body
+;;

unikernel/duniverse/ppx_sexp_conv/expander/lifted.mli

@@ -0,0 +1,20 @@
+open! Base
+open Ppxlib
+
+(** Represents an ['a], along with some user expressions that should lifted out of the
+    scope of internal bindings. For example, if a user writes [[@@default x]], they mean
+    [x] in the surface code, not some temporary variable [x] added by ppx machinery. *)
+type 'a t
+
+(** As a monad, combines all client expressions so they can be lifted to the outermost
+    level of generated code. *)
+include Monad.S with type 'a t := 'a t
+
+(** Lifts the given expression and binds it to a fresh variable starting with [prefix].
+    The expression is evaluated each time it is referred to. The binding is annotated with
+    [ty]. Uses [loc] for generated code. *)
+val create : loc:location -> prefix:string -> ty:core_type -> expression -> expression t
+
+(** Uses [let] to bind all lifted user expressions, with the contained expression as the
+    body. Should be called in whatever scope the user should be able to refer to. *)
+val let_bind_user_expressions : expression t -> loc:location -> expression

unikernel/duniverse/ppx_sexp_conv/expander/ppx_sexp_conv_expander.ml

@@ -0,0 +1,55 @@
+open Base
+open Ppxlib
+open Ast_builder.Default
+module Attrs = Attrs
+module Record_field_attrs = Record_field_attrs
+open Expand_sexp_of
+open Expand_of_sexp
+
+module Sexp_of = struct
+  let type_extension ty =
+    Sig_generate_sexp_of.type_of_sexp_of ~loc:{ ty.ptyp_loc with loc_ghost = true } ty
+  ;;
+
+  let core_type ty = Str_generate_sexp_of.sexp_of_core_type ty
+  let sig_type_decl = Sig_generate_sexp_of.mk_sig
+  let sig_exception = Sig_generate_sexp_of.mk_sig_exn
+  let str_type_decl = Str_generate_sexp_of.sexp_of_tds
+  let str_exception = Str_generate_sexp_of.sexp_of_exn
+end
+
+module Sexp_grammar = Ppx_sexp_conv_grammar
+
+module Of_sexp = struct
+  let type_extension ty = Sig_generate_of_sexp.type_of_of_sexp ~loc:ty.ptyp_loc ty
+  let core_type = Str_generate_of_sexp.core_type_of_sexp
+
+  let sig_type_decl ~poly ~loc ~path tds =
+    Sig_generate_of_sexp.mk_sig ~poly ~loc ~path tds
+  ;;
+
+  let str_type_decl ~loc ~poly ~path tds =
+    Str_generate_of_sexp.tds_of_sexp ~loc ~poly ~path tds
+  ;;
+end
+
+module Sig_sexp = struct
+  let mk_sig ~loc ~path decls =
+    List.concat
+      [ Sig_generate_sexp_of.mk_sig ~loc ~path decls
+      ; Sig_generate_of_sexp.mk_sig ~poly:false ~loc ~path decls
+      ]
+  ;;
+
+  let sig_type_decl ~loc ~path ((_rf, tds) as decls) =
+    match
+      mk_named_sig
+        ~loc
+        ~sg_name:"Sexplib0.Sexpable.S"
+        ~handle_polymorphic_variant:false
+        tds
+    with
+    | Some include_infos -> [ psig_include ~loc include_infos ]
+    | None -> mk_sig ~loc ~path decls
+  ;;
+end

unikernel/duniverse/ppx_sexp_conv/expander/ppx_sexp_conv_expander.mli

@@ -0,0 +1,72 @@
+open Ppxlib
+module Attrs = Attrs
+module Record_field_attrs = Record_field_attrs
+
+module Sexp_of : sig
+  val type_extension : core_type -> core_type
+  val core_type : core_type -> expression
+
+  val sig_type_decl
+    :  loc:Location.t
+    -> path:string
+    -> rec_flag * type_declaration list
+    -> signature
+
+  val sig_exception : loc:Location.t -> path:string -> type_exception -> signature
+
+  val str_type_decl
+    :  loc:Location.t
+    -> path:string
+    -> rec_flag * type_declaration list
+    -> structure
+
+  val str_exception : loc:Location.t -> path:string -> type_exception -> structure
+end
+
+module Of_sexp : sig
+  val type_extension : core_type -> core_type
+  val core_type : path:string -> core_type -> expression
+
+  val sig_type_decl
+    :  poly:bool
+    -> loc:Location.t
+    -> path:string
+    -> rec_flag * type_declaration list
+    -> signature
+
+  val str_type_decl
+    :  loc:Location.t
+    -> poly:bool (** the type is annotated with sexp_poly instead of sexp *)
+    -> path:string (** the module path within the file *)
+    -> rec_flag * type_declaration list
+    -> structure
+end
+
+module Sexp_grammar : sig
+  val type_extension : ctxt:Expansion_context.Extension.t -> core_type -> core_type
+
+  val core_type
+    :  tags_of_doc_comments:bool
+    -> ctxt:Expansion_context.Extension.t
+    -> core_type
+    -> expression
+
+  val sig_type_decl
+    :  ctxt:Expansion_context.Deriver.t
+    -> rec_flag * type_declaration list
+    -> signature
+
+  val str_type_decl
+    :  ctxt:Expansion_context.Deriver.t
+    -> rec_flag * type_declaration list
+    -> bool (** [true] means capture doc comments as tags *)
+    -> structure
+end
+
+module Sig_sexp : sig
+  val sig_type_decl
+    :  loc:Location.t
+    -> path:string
+    -> rec_flag * type_declaration list
+    -> signature
+end

unikernel/duniverse/ppx_sexp_conv/expander/ppx_sexp_conv_grammar.ml

@@ -0,0 +1,722 @@
+open! Base
+open! Ppxlib
+open Ast_builder.Default
+
+let copy =
+  object
+    inherit Ast_traverse.map
+    method! location loc = { loc with loc_ghost = true }
+    method! attributes _ = []
+  end
+;;
+
+let unsupported ~loc string =
+  Location.raise_errorf ~loc "sexp_grammar: %s are unsupported" string
+;;
+
+let ewith_tag ~loc ~key ~value grammar =
+  [%expr { key = [%e key]; value = [%e value]; grammar = [%e grammar] }]
+;;
+
+let eno_tag ~loc grammar = [%expr No_tag [%e grammar]]
+let etag ~loc with_tag = [%expr Tag [%e with_tag]]
+let etagged ~loc with_tag = [%expr Tagged [%e with_tag]]
+
+let tag_of_doc_comment ~loc comment =
+  ( [%expr Ppx_sexp_conv_lib.Sexp_grammar.doc_comment_tag]
+  , [%expr Atom [%e estring ~loc comment]] )
+;;
+
+module Tags = struct
+  type t =
+    { defined_using_tags : expression option
+    ; defined_using_tag : (expression * expression) list
+    }
+
+  let get x ~tags ~tag =
+    { defined_using_tags = Attribute.get tags x
+    ; defined_using_tag = Attribute.get tag x |> Option.value ~default:[]
+    }
+  ;;
+end
+
+let rec with_tag_assoc_list grammar ~loc ~tags_expr ~wrap_tag ~wrap_tags =
+  match tags_expr with
+  | [%expr []] -> grammar
+  | [%expr ([%e? key], [%e? value]) :: [%e? tags_expr]] ->
+    wrap_tag
+      ~loc
+      (ewith_tag
+         ~loc
+         ~key
+         ~value
+         (with_tag_assoc_list grammar ~loc ~tags_expr ~wrap_tag ~wrap_tags))
+  | _ -> wrap_tags grammar ~loc ~tags_expr
+;;
+
+let with_tags grammar ~wrap_tag ~wrap_tags ~loc ~(tags : Tags.t) ~comments =
+  let tags_from_comments = List.map comments ~f:(tag_of_doc_comment ~loc) in
+  let init =
+    match tags.defined_using_tags with
+    | None -> grammar
+    | Some tags_expr -> with_tag_assoc_list grammar ~loc ~tags_expr ~wrap_tag ~wrap_tags
+  in
+  List.fold_right
+    (List.concat [ tags_from_comments; tags.defined_using_tag ])
+    ~init
+    ~f:(fun (key, value) grammar -> wrap_tag ~loc (ewith_tag ~loc ~key ~value grammar))
+;;
+
+let with_tags_as_list grammar ~core_type ~loc ~tags ~comments =
+  let wrap_tags grammar ~loc ~tags_expr =
+    [%expr
+      Sexplib0.Sexp_conv.sexp_grammar_with_tag_list
+        ([%e grammar] : [%t core_type] Sexplib0.Sexp_grammar.with_tag_list)
+        ~tags:[%e tags_expr]]
+  in
+  with_tags (eno_tag ~loc grammar) ~wrap_tag:etag ~wrap_tags ~loc ~tags ~comments
+;;
+
+let with_tags_as_grammar grammar ~loc ~tags ~comments =
+  let wrap_tags grammar ~loc ~tags_expr =
+    [%expr Sexplib0.Sexp_conv.sexp_grammar_with_tags [%e grammar] ~tags:[%e tags_expr]]
+  in
+  with_tags grammar ~wrap_tag:etagged ~wrap_tags ~loc ~tags ~comments
+;;
+
+let grammar_name name = name ^ "_sexp_grammar"
+let tyvar_grammar_name name = grammar_name ("_'" ^ name)
+let estr { loc; txt } = estring ~loc txt
+
+let grammar_type ~loc core_type =
+  [%type: [%t copy#core_type core_type] Sexplib0.Sexp_grammar.t]
+;;
+
+let abstract_grammar ~ctxt ~loc id =
+  let module_name =
+    ctxt |> Expansion_context.Deriver.code_path |> Code_path.fully_qualified_path
+  in
+  [%expr Any [%e estr { id with txt = String.concat ~sep:"." [ module_name; id.txt ] }]]
+;;
+
+let arrow_grammar ~loc = [%expr Sexplib0.Sexp_conv.fun_sexp_grammar.untyped]
+let opaque_grammar ~loc = [%expr Sexplib0.Sexp_conv.opaque_sexp_grammar.untyped]
+let any_grammar ~loc name = [%expr Any [%e estring ~loc name]]
+let list_grammar ~loc expr = [%expr List [%e expr]]
+let many_grammar ~loc expr = [%expr Many [%e expr]]
+let fields_grammar ~loc expr = [%expr Fields [%e expr]]
+let tyvar_grammar ~loc expr = [%expr Tyvar [%e expr]]
+let recursive_grammar ~loc name args = [%expr Recursive ([%e name], [%e args])]
+
+let tycon_grammar ~loc tycon_name params defns =
+  [%expr Tycon ([%e tycon_name], [%e params], [%e defns])]
+;;
+
+let defns_type ~loc = [%type: Sexplib0.Sexp_grammar.defn Stdlib.List.t Stdlib.Lazy.t]
+
+let untyped_grammar ~loc expr =
+  match expr with
+  | [%expr { untyped = [%e? untyped] }] -> untyped
+  | _ -> [%expr [%e expr].untyped]
+;;
+
+let typed_grammar ~loc expr =
+  match expr with
+  | [%expr [%e? typed].untyped] -> typed
+  | _ -> [%expr { untyped = [%e expr] }]
+;;
+
+let annotated_grammar ~loc expr core_type =
+  pexp_constraint ~loc expr (grammar_type ~loc core_type)
+;;
+
+let defn_expr ~loc ~tycon ~tyvars ~grammar =
+  [%expr { tycon = [%e tycon]; tyvars = [%e tyvars]; grammar = [%e grammar] }]
+;;
+
+let union_grammar ~loc exprs =
+  match exprs with
+  | [] -> [%expr Union []]
+  | [ expr ] -> expr
+  | _ -> [%expr Union [%e elist ~loc exprs]]
+;;
+
+let tuple_grammar ~loc exprs =
+  List.fold_right exprs ~init:[%expr Empty] ~f:(fun expr rest ->
+    [%expr Cons ([%e expr], [%e rest])])
+;;
+
+let atom_clause ~loc = [%expr Atom_clause]
+let list_clause ~loc args = [%expr List_clause { args = [%e args] }]
+
+module Variant_clause_type = struct
+  type t =
+    { name : label loc
+    ; comments : string list
+    ; tags : Tags.t
+    ; clause_kind : expression
+    }
+
+  let to_grammar_expr { name; comments; tags; clause_kind } ~loc =
+    [%expr { name = [%e estr name]; clause_kind = [%e clause_kind] }]
+    |> with_tags_as_list
+         ~loc:name.loc
+         ~comments
+         ~tags
+         ~core_type:[%type: Sexplib0.Sexp_grammar.clause]
+  ;;
+end
+
+let variant_grammars ~loc ~case_sensitivity ~clauses =
+  match List.is_empty clauses with
+  | true -> []
+  | false ->
+    let clause_exprs = List.map clauses ~f:(Variant_clause_type.to_grammar_expr ~loc) in
+    let grammar =
+      [%expr
+        Variant
+          { case_sensitivity = [%e case_sensitivity]
+          ; clauses = [%e elist ~loc clause_exprs]
+          }]
+    in
+    [ grammar ]
+;;
+
+(* Wrap [expr] in [fun a b ... ->] for type parameters. *)
+let td_params_fun td expr =
+  let loc = td.ptype_loc in
+  let params =
+    List.map td.ptype_params ~f:(fun param ->
+      let { loc; txt } = get_type_param_name param in
+      pvar ~loc (tyvar_grammar_name txt))
+  in
+  eabstract ~loc params expr
+;;
+
+module Row_field_type = struct
+  type t =
+    | Inherit of core_type
+    | Tag_no_arg of string loc
+    | Tag_with_arg of string loc * core_type
+
+  let of_row_field ~loc row_field =
+    match row_field with
+    | Rinherit core_type -> Inherit core_type
+    | Rtag (name, possibly_no_arg, possible_type_args) ->
+      (match possibly_no_arg, possible_type_args with
+       | true, [] -> Tag_no_arg name
+       | false, [ core_type ] -> Tag_with_arg (name, core_type)
+       | false, [] -> unsupported ~loc "empty polymorphic variant types"
+       | true, _ :: _ | false, _ :: _ :: _ -> unsupported ~loc "intersection types")
+  ;;
+end
+
+let attr_doc_comments attributes ~tags_of_doc_comments =
+  match tags_of_doc_comments with
+  | false -> []
+  | true ->
+    let doc_pattern = Ast_pattern.(pstr (pstr_eval (estring __) nil ^:: nil)) in
+    List.filter_map attributes ~f:(fun attribute ->
+      match attribute.attr_name.txt with
+      | "ocaml.doc" | "doc" ->
+        Ast_pattern.parse
+          doc_pattern
+          attribute.attr_loc
+          attribute.attr_payload
+          ~on_error:(fun () -> None)
+          (fun doc -> Some doc)
+      | _ -> None)
+;;
+
+let grammar_of_type_tags core_type grammar ~tags_of_doc_comments =
+  let tags = Tags.get core_type ~tags:Attrs.tags_type ~tag:Attrs.tag_type in
+  let loc = core_type.ptyp_loc in
+  let comments = attr_doc_comments ~tags_of_doc_comments core_type.ptyp_attributes in
+  with_tags_as_grammar grammar ~loc ~tags ~comments
+;;
+
+let grammar_of_field_tags field grammar ~tags_of_doc_comments =
+  let tags = Tags.get field ~tags:Attrs.tags_ld ~tag:Attrs.tag_ld in
+  let loc = field.pld_loc in
+  let comments = attr_doc_comments ~tags_of_doc_comments field.pld_attributes in
+  with_tags_as_list
+    grammar
+    ~loc
+    ~tags
+    ~comments
+    ~core_type:[%type: Sexplib0.Sexp_grammar.field]
+;;
+
+let rec grammar_of_type core_type ~rec_flag ~tags_of_doc_comments =
+  let loc = core_type.ptyp_loc in
+  let grammar =
+    let from_attribute =
+      match
+        ( Attribute.get Attrs.grammar_custom core_type
+        , Attribute.get Attrs.grammar_any core_type )
+      with
+      | Some _, Some _ ->
+        Some
+          [%expr
+            [%ocaml.warning
+              "[@sexp_grammar.custom] and [@sexp_grammar.any] are mutually exclusive"]]
+      | Some expr, None ->
+        Some (untyped_grammar ~loc (annotated_grammar ~loc expr core_type))
+      | None, Some maybe_name ->
+        Some (any_grammar ~loc (Option.value maybe_name ~default:"ANY"))
+      | None, None ->
+        (* only check [[@sexp.opaque]] if neither other attribute is present, so that it
+           only counts as using the attribute when we actually base the grammar on it *)
+        (match Attribute.get Attrs.opaque core_type with
+         | Some () -> Some (opaque_grammar ~loc)
+         | None -> None)
+    in
+    match from_attribute with
+    | Some expr -> expr
+    | None ->
+      (match Ppxlib_jane.Jane_syntax.Core_type.of_ast core_type with
+       | Some (Jtyp_tuple ltps, _attrs) ->
+         grammar_of_labeled_tuple ~loc ~rec_flag ~tags_of_doc_comments ltps
+       | Some (Jtyp_layout _, _) | None ->
+         (match core_type.ptyp_desc with
+          | Ptyp_any -> any_grammar ~loc "_"
+          | Ptyp_var name ->
+            (match rec_flag with
+             | Recursive ->
+               (* For recursive grammars, [grammar_of_type] for any type variables is called
+                  inside a [defn]. The variables should therefore be resolved as [Tyvar]
+                  grammars. *)
+               tyvar_grammar ~loc (estring ~loc name)
+             | Nonrecursive ->
+               (* Outside recursive [defn]s, type variables are passed in as function
+                  arguments. *)
+               unapplied_type_constr_conv
+                 ~loc
+                 ~f:tyvar_grammar_name
+                 (Located.lident ~loc name)
+               |> untyped_grammar ~loc)
+          | Ptyp_arrow _ -> arrow_grammar ~loc
+          | Ptyp_tuple list ->
+            List.map ~f:(grammar_of_type ~rec_flag ~tags_of_doc_comments) list
+            |> tuple_grammar ~loc
+            |> list_grammar ~loc
+          | Ptyp_constr (id, args) ->
+            List.map args ~f:(fun core_type ->
+              let loc = core_type.ptyp_loc in
+              grammar_of_type ~rec_flag ~tags_of_doc_comments core_type
+              |> typed_grammar ~loc)
+            |> type_constr_conv ~loc ~f:grammar_name id
+            |> untyped_grammar ~loc
+          | Ptyp_object _ -> unsupported ~loc "object types"
+          | Ptyp_class _ -> unsupported ~loc "class types"
+          | Ptyp_alias _ -> unsupported ~loc "type aliases"
+          | Ptyp_variant (rows, closed_flag, (_ : string list option)) ->
+            (match closed_flag with
+             | Open -> unsupported ~loc "open polymorphic variant types"
+             | Closed ->
+               grammar_of_polymorphic_variant ~loc ~rec_flag ~tags_of_doc_comments rows)
+          | Ptyp_poly _ -> unsupported ~loc "explicitly polymorphic types"
+          | Ptyp_package _ -> unsupported ~loc "first-class module types"
+          | Ptyp_extension _ -> unsupported ~loc "unexpanded ppx extensions"
+          | Ptyp_open _ -> unsupported ~loc "local module open"))
+  in
+  grammar_of_type_tags core_type grammar ~tags_of_doc_comments
+
+and grammar_of_labeled_tuple ~loc ~rec_flag ~tags_of_doc_comments alist =
+  assert (Labeled_tuple.is_valid alist);
+  let fields =
+    List.concat_map alist ~f:(fun (lbl, typ) ->
+      let lbl = Labeled_tuple.atom_of_label lbl in
+      let field = grammar_of_type ~rec_flag ~tags_of_doc_comments typ in
+      let clauses : Variant_clause_type.t list =
+        (* Labeled tuples are encoded as a list of singleton variants, where the
+           constructor name is used for the label. *)
+        [ { name = { txt = lbl; loc }
+          ; comments = []
+          ; tags =
+              { defined_using_tags = None; defined_using_tag = [] }
+              (* We can use empty comments and tags because it's not possible to attach an
+             attribute to a labeled tuple field. *)
+          ; clause_kind = list_clause ~loc [%expr Cons ([%e field], Empty)]
+          }
+        ]
+      in
+      let case_sensitivity = [%expr Case_sensitive] in
+      variant_grammars ~loc ~case_sensitivity ~clauses)
+  in
+  list_grammar ~loc (tuple_grammar ~loc fields)
+
+and grammar_of_polymorphic_variant ~loc ~rec_flag ~tags_of_doc_comments rows =
+  let inherits, clauses =
+    List.partition_map rows ~f:(fun row : (_, Variant_clause_type.t) Either.t ->
+      let tags = Tags.get row ~tags:Attrs.tags_poly ~tag:Attrs.tag_poly in
+      let comments = attr_doc_comments ~tags_of_doc_comments row.prf_attributes in
+      match Attribute.get Attrs.list_poly row with
+      | Some () ->
+        (match Row_field_type.of_row_field ~loc row.prf_desc with
+         | Tag_with_arg (name, [%type: [%t? ty] list]) ->
+           let clause_kind =
+             grammar_of_type ~rec_flag ~tags_of_doc_comments ty
+             |> many_grammar ~loc
+             |> list_clause ~loc
+           in
+           Second { name; comments; tags; clause_kind }
+         | _ -> Attrs.invalid_attribute ~loc Attrs.list_poly "_ list")
+      | None ->
+        (match Row_field_type.of_row_field ~loc row.prf_desc with
+         | Inherit core_type ->
+           First
+             (grammar_of_type ~rec_flag ~tags_of_doc_comments core_type
+              |> with_tags_as_grammar ~loc ~tags ~comments)
+         | Tag_no_arg name ->
+           Second { name; comments; tags; clause_kind = atom_clause ~loc }
+         | Tag_with_arg (name, core_type) ->
+           let clause_kind =
+             [ grammar_of_type ~rec_flag ~tags_of_doc_comments core_type ]
+             |> tuple_grammar ~loc
+             |> list_clause ~loc
+           in
+           Second { name; comments; tags; clause_kind }))
+  in
+  variant_grammars ~loc ~case_sensitivity:[%expr Case_sensitive] ~clauses
+  |> List.append inherits
+  |> union_grammar ~loc
+;;
+
+let record_expr ~loc ~rec_flag ~tags_of_doc_comments ~extra_attr syntax fields =
+  let fields =
+    List.map fields ~f:(fun field ->
+      let loc = field.pld_loc in
+      let field_kind = Record_field_attrs.Of_sexp.create ~loc field in
+      let required =
+        match field_kind with
+        | Specific Required -> true
+        | Specific (Default _)
+        | Sexp_bool | Sexp_option _ | Sexp_array _ | Sexp_list _ | Omit_nil -> false
+      in
+      let args =
+        match field_kind with
+        | Specific Required | Specific (Default _) | Omit_nil ->
+          [%expr
+            Cons
+              ([%e grammar_of_type ~tags_of_doc_comments ~rec_flag field.pld_type], Empty)]
+        | Sexp_bool -> [%expr Empty]
+        | Sexp_option ty ->
+          [%expr Cons ([%e grammar_of_type ~tags_of_doc_comments ~rec_flag ty], Empty)]
+        | Sexp_list ty | Sexp_array ty ->
+          [%expr
+            Cons
+              (List (Many [%e grammar_of_type ~tags_of_doc_comments ~rec_flag ty]), Empty)]
+      in
+      [%expr
+        { name = [%e estr field.pld_name]
+        ; required = [%e ebool ~loc required]
+        ; args = [%e args]
+        }]
+      |> grammar_of_field_tags field ~tags_of_doc_comments)
+  in
+  let allow_extra_fields =
+    match Attribute.get extra_attr syntax with
+    | Some () -> true
+    | None -> false
+  in
+  [%expr
+    { allow_extra_fields = [%e ebool ~loc allow_extra_fields]
+    ; fields = [%e elist ~loc fields]
+    }]
+;;
+
+let grammar_of_variant ~loc ~rec_flag ~tags_of_doc_comments clause_decls =
+  let clauses =
+    List.map clause_decls ~f:(fun clause : Variant_clause_type.t ->
+      let loc = clause.pcd_loc in
+      let tags = Tags.get clause ~tags:Attrs.tags_cd ~tag:Attrs.tag_cd in
+      let comments = attr_doc_comments ~tags_of_doc_comments clause.pcd_attributes in
+      match Attribute.get Attrs.list_variant clause with
+      | Some () ->
+        (match clause.pcd_args with
+         | Pcstr_tuple [ [%type: [%t? ty] list] ] ->
+           let args =
+             many_grammar ~loc (grammar_of_type ty ~rec_flag ~tags_of_doc_comments)
+           in
+           { name = clause.pcd_name; comments; tags; clause_kind = list_clause ~loc args }
+         | _ -> Attrs.invalid_attribute ~loc Attrs.list_variant "_ list")
+      | None ->
+        (match clause.pcd_args with
+         | Pcstr_tuple [] ->
+           { name = clause.pcd_name; comments; tags; clause_kind = atom_clause ~loc }
+         | Pcstr_tuple (_ :: _ as args) ->
+           let args =
+             tuple_grammar
+               ~loc
+               (List.map args ~f:(grammar_of_type ~rec_flag ~tags_of_doc_comments))
+           in
+           { name = clause.pcd_name; comments; tags; clause_kind = list_clause ~loc args }
+         | Pcstr_record fields ->
+           let args =
+             record_expr
+               ~loc
+               ~rec_flag
+               ~tags_of_doc_comments
+               ~extra_attr:Attrs.allow_extra_fields_cd
+               clause
+               fields
+             |> fields_grammar ~loc
+           in
+           { name = clause.pcd_name; comments; tags; clause_kind = list_clause ~loc args }))
+  in
+  variant_grammars
+    ~loc
+    ~case_sensitivity:[%expr Case_sensitive_except_first_character]
+    ~clauses
+  |> union_grammar ~loc
+;;
+
+let grammar_of_td ~ctxt ~rec_flag ~tags_of_doc_comments td =
+  let loc = td.ptype_loc in
+  match td.ptype_kind with
+  | Ptype_open -> unsupported ~loc "open types"
+  | Ptype_record fields ->
+    record_expr
+      ~loc
+      ~rec_flag
+      ~tags_of_doc_comments
+      ~extra_attr:Attrs.allow_extra_fields_td
+      td
+      fields
+    |> fields_grammar ~loc
+    |> list_grammar ~loc
+  | Ptype_variant clauses ->
+    grammar_of_variant ~loc ~rec_flag ~tags_of_doc_comments clauses
+  | Ptype_abstract ->
+    (match td.ptype_manifest with
+     | None -> abstract_grammar ~ctxt ~loc td.ptype_name
+     | Some core_type -> grammar_of_type ~rec_flag ~tags_of_doc_comments core_type)
+;;
+
+let pattern_of_td td =
+  let { loc; txt } = td.ptype_name in
+  ppat_constraint
+    ~loc
+    (pvar ~loc (grammar_name txt))
+    (ptyp_poly
+       ~loc
+       (List.map td.ptype_params ~f:get_type_param_name)
+       (combinator_type_of_type_declaration td ~f:grammar_type))
+;;
+
+(* Any grammar expression that is purely a constant does no work, and does not need to be
+   wrapped in [Lazy]. *)
+let rec is_preallocated_constant expr =
+  match expr.pexp_desc with
+  | Pexp_constraint (expr, _) | Pexp_coerce (expr, _, _) | Pexp_open (_, expr) ->
+    is_preallocated_constant expr
+  | Pexp_constant _ -> true
+  | Pexp_tuple args -> List.for_all ~f:is_preallocated_constant args
+  | Pexp_variant (_, maybe_arg) | Pexp_construct (_, maybe_arg) ->
+    Option.for_all ~f:is_preallocated_constant maybe_arg
+  | Pexp_record (fields, maybe_template) ->
+    List.for_all fields ~f:(fun (_, expr) -> is_preallocated_constant expr)
+    && Option.for_all ~f:is_preallocated_constant maybe_template
+  | _ -> false
+;;
+
+(* Any grammar expression that just refers to a previously defined grammar also does not
+   need to be wrapped in [Lazy]. Accessing the previous grammar is work, but building the
+   closure for a lazy value is at least as much work anyway. *)
+let rec is_variable_access expr =
+  match expr.pexp_desc with
+  | Pexp_constraint (expr, _) | Pexp_coerce (expr, _, _) | Pexp_open (_, expr) ->
+    is_variable_access expr
+  | Pexp_ident _ -> true
+  | Pexp_field (expr, _) -> is_variable_access expr
+  | _ -> false
+;;
+
+let grammar_needs_lazy_wrapper expr =
+  not (is_preallocated_constant expr || is_variable_access expr)
+;;
+
+let lazy_grammar ~loc td expr =
+  if List.is_empty td.ptype_params
+     (* polymorphic types generate functions, so the body does not need a [lazy] wrapper *)
+     && grammar_needs_lazy_wrapper expr
+  then [%expr Lazy (lazy [%e expr])]
+  else expr
+;;
+
+let force_expr ~loc expr = [%expr Stdlib.Lazy.force [%e expr]]
+
+(* Definitions of grammars that do not refer to each other. *)
+let nonrecursive_grammars ~ctxt ~loc ~tags_of_doc_comments td_lists =
+  List.concat_map td_lists ~f:(fun tds ->
+    List.map tds ~f:(fun td ->
+      let td = name_type_params_in_td td in
+      let loc = td.ptype_loc in
+      let pat = pattern_of_td td in
+      let expr =
+        grammar_of_td ~ctxt ~rec_flag:Nonrecursive ~tags_of_doc_comments td
+        |> lazy_grammar td ~loc
+        |> typed_grammar ~loc
+        |> td_params_fun td
+      in
+      value_binding ~loc ~pat ~expr)
+    |> pstr_value_list ~loc Nonrecursive)
+;;
+
+(* Type constructor grammars used to "tie the knot" for (mutally) recursive grammars. *)
+let recursive_grammar_tycons tds =
+  List.map tds ~f:(fun td ->
+    let td = name_type_params_in_td td in
+    let loc = td.ptype_loc in
+    let pat = pattern_of_td td in
+    let expr =
+      recursive_grammar
+        ~loc
+        (estr td.ptype_name)
+        (List.map td.ptype_params ~f:(fun param ->
+           let { loc; txt } = get_type_param_name param in
+           tyvar_grammar_name txt |> evar ~loc |> untyped_grammar ~loc)
+         |> elist ~loc)
+      |> typed_grammar ~loc
+      |> td_params_fun td
+    in
+    value_binding ~loc ~pat ~expr)
+;;
+
+(* Recursive grammar definitions, based on the type constructors from above. *)
+let recursive_grammar_defns ~ctxt ~loc ~tags_of_doc_comments tds =
+  List.map tds ~f:(fun td ->
+    let td = name_type_params_in_td td in
+    let loc = td.ptype_loc in
+    let tycon = estr td.ptype_name in
+    let tyvars =
+      List.map td.ptype_params ~f:(fun param -> estr (get_type_param_name param))
+      |> elist ~loc
+    in
+    let grammar = grammar_of_td ~ctxt ~rec_flag:Recursive ~tags_of_doc_comments td in
+    defn_expr ~loc ~tycon ~tyvars ~grammar)
+  |> elist ~loc
+;;
+
+(* Grammar expression using [Recursive] and a shared definition of grammar definitions.
+   The shared definitions are wrapped in [lazy] to avoid toplevel side effects. *)
+let recursive_grammar_expr ~defns_name td =
+  let td = name_type_params_in_td td in
+  let loc = td.ptype_loc in
+  let pat = pattern_of_td td in
+  let expr =
+    let tyvars =
+      List.map td.ptype_params ~f:(fun param ->
+        let { loc; txt } = get_type_param_name param in
+        tyvar_grammar_name txt |> evar ~loc |> untyped_grammar ~loc)
+      |> elist ~loc
+    in
+    tycon_grammar
+      ~loc
+      (estr td.ptype_name)
+      tyvars
+      (evar ~loc defns_name |> force_expr ~loc)
+    |> lazy_grammar td ~loc
+    |> typed_grammar ~loc
+    |> td_params_fun td
+  in
+  value_binding ~loc ~pat ~expr
+;;
+
+(* Puts together recursive grammar definitions from the parts implemented above. *)
+let recursive_grammars ~ctxt ~loc ~tags_of_doc_comments tds =
+  match List.is_empty tds with
+  | true -> []
+  | false ->
+    let defns_name = gen_symbol ~prefix:"grammars" () in
+    let defns_item =
+      let expr =
+        recursive_grammar_defns ~ctxt ~loc ~tags_of_doc_comments tds
+        |> pexp_let ~loc Nonrecursive (recursive_grammar_tycons tds)
+        |> pexp_lazy ~loc
+      in
+      let pat = ppat_constraint ~loc (pvar ~loc defns_name) (defns_type ~loc) in
+      pstr_value ~loc Nonrecursive [ value_binding ~loc ~pat ~expr ]
+    in
+    let grammars_item =
+      List.map tds ~f:(recursive_grammar_expr ~defns_name) |> pstr_value ~loc Nonrecursive
+    in
+    [%str
+      include struct
+        open struct
+          [%%i defns_item]
+        end
+
+        [%%i grammars_item]
+      end]
+;;
+
+let partition_recursive_and_nonrecursive ~rec_flag tds =
+  match (rec_flag : rec_flag) with
+  | Nonrecursive -> [], [ tds ]
+  | Recursive ->
+    (* Pulling out non-recursive references repeatedly means we only "tie the knot" for
+       variables that actually need it, and we don't have to manually [ignore] the added
+       bindings in case they are unused. *)
+    let rec loop tds ~acc =
+      let obj =
+        object
+          inherit type_is_recursive Recursive tds
+          method recursion td = {<type_names = [ td.ptype_name.txt ]>}#go ()
+        end
+      in
+      let recursive, nonrecursive =
+        List.partition_tf tds ~f:(fun td ->
+          match obj#recursion td with
+          | Recursive -> true
+          | Nonrecursive -> false)
+      in
+      if List.is_empty recursive || List.is_empty nonrecursive
+      then recursive, nonrecursive :: acc
+      else loop recursive ~acc:(nonrecursive :: acc)
+    in
+    loop tds ~acc:[]
+;;
+
+let str_type_decl ~ctxt (rec_flag, tds) tags_of_doc_comments =
+  let loc = Expansion_context.Deriver.derived_item_loc ctxt in
+  let recursive, nonrecursive = partition_recursive_and_nonrecursive ~rec_flag tds in
+  [ recursive_grammars ~ctxt ~loc ~tags_of_doc_comments recursive
+  ; nonrecursive_grammars ~ctxt ~loc ~tags_of_doc_comments nonrecursive
+  ]
+  |> List.concat
+;;
+
+let sig_type_decl ~ctxt:_ (_rec_flag, tds) =
+  List.map tds ~f:(fun td ->
+    let loc = td.ptype_loc in
+    value_description
+      ~loc
+      ~name:(Loc.map td.ptype_name ~f:grammar_name)
+      ~type_:(combinator_type_of_type_declaration td ~f:grammar_type)
+      ~prim:[]
+    |> psig_value ~loc)
+;;
+
+let extension_loc ~ctxt =
+  let loc = Expansion_context.Extension.extension_point_loc ctxt in
+  { loc with loc_ghost = true }
+;;
+
+let core_type ~tags_of_doc_comments ~ctxt core_type =
+  let loc = extension_loc ~ctxt in
+  pexp_constraint
+    ~loc
+    (core_type
+     |> grammar_of_type ~rec_flag:Nonrecursive ~tags_of_doc_comments
+     |> typed_grammar ~loc)
+    (core_type |> grammar_type ~loc)
+  |> Merlin_helpers.hide_expression
+;;
+
+let type_extension ~ctxt core_type =
+  assert_no_attributes_in#core_type core_type;
+  let loc = extension_loc ~ctxt in
+  core_type |> grammar_type ~loc
+;;

unikernel/duniverse/ppx_sexp_conv/expander/ppx_sexp_conv_grammar.mli

@@ -0,0 +1,21 @@
+open! Base
+open! Ppxlib
+
+val type_extension : ctxt:Expansion_context.Extension.t -> core_type -> core_type
+
+val core_type
+  :  tags_of_doc_comments:bool
+  -> ctxt:Expansion_context.Extension.t
+  -> core_type
+  -> expression
+
+val sig_type_decl
+  :  ctxt:Expansion_context.Deriver.t
+  -> rec_flag * type_declaration list
+  -> signature
+
+val str_type_decl
+  :  ctxt:Expansion_context.Deriver.t
+  -> rec_flag * type_declaration list
+  -> bool (** [true] means capture doc comments as tags *)
+  -> structure

unikernel/duniverse/ppx_sexp_conv/expander/record_field_attrs.ml

@@ -0,0 +1,133 @@
+open! Base
+open! Ppxlib
+open Attrs
+
+module Generic = struct
+  type 'specific t =
+    | Omit_nil
+    | Sexp_array of core_type
+    | Sexp_bool
+    | Sexp_list of core_type
+    | Sexp_option of core_type
+    | Specific of 'specific
+end
+
+open Generic
+
+let get_attribute attr ld ~f =
+  Option.map (Attribute.get attr ld) ~f:(fun x -> f x, Attribute.name attr)
+;;
+
+let create ~loc specific_getters ld ~if_no_attribute =
+  let generic_getters =
+    [ get_attribute omit_nil ~f:(fun () -> Omit_nil)
+    ; (fun ld ->
+        match ld.pld_type with
+        | ty when Option.is_some (Attribute.get bool ld) ->
+          (match ty with
+           | [%type: bool] -> Some (Sexp_bool, "[@sexp.bool]")
+           | _ -> invalid_attribute ~loc bool "bool")
+        | ty when Option.is_some (Attribute.get option ld) ->
+          (match ty with
+           | [%type: [%t? ty] option] -> Some (Sexp_option ty, "[@sexp.option]")
+           | _ -> invalid_attribute ~loc option "_ option")
+        | ty when Option.is_some (Attribute.get list ld) ->
+          (match ty with
+           | [%type: [%t? ty] list] -> Some (Sexp_list ty, "[@sexp.list]")
+           | _ -> invalid_attribute ~loc list "_ list")
+        | ty when Option.is_some (Attribute.get array ld) ->
+          (match ty with
+           | [%type: [%t? ty] array] -> Some (Sexp_array ty, "[@sexp.array]")
+           | _ -> invalid_attribute ~loc array "_ array")
+        | _ -> None)
+    ]
+  in
+  let getters =
+    let wrapped_getters =
+      List.map specific_getters ~f:(fun get ld ->
+        Option.map (get ld) ~f:(fun (specific, string) -> Specific specific, string))
+    in
+    List.concat [ wrapped_getters; generic_getters ]
+  in
+  match List.filter_map getters ~f:(fun f -> f ld) with
+  | [] -> Specific if_no_attribute
+  | [ (v, _) ] -> v
+  | _ :: _ :: _ as attributes ->
+    Location.raise_errorf
+      ~loc
+      "The following elements are mutually exclusive: %s"
+      (String.concat ~sep:" " (List.map attributes ~f:snd))
+;;
+
+let strip_attributes =
+  object
+    inherit Ast_traverse.map
+    method! attributes _ = []
+  end
+;;
+
+let lift_default ~loc ld expr =
+  let ty = strip_attributes#core_type ld.pld_type in
+  Lifted.create ~loc ~prefix:"default" ~ty expr
+;;
+
+let lift_drop_default ~loc ld expr =
+  let ty = strip_attributes#core_type ld.pld_type in
+  Lifted.create
+    ~loc
+    ~prefix:"drop_default"
+    ~ty:[%type: [%t ty] -> [%t ty] -> Stdlib.Bool.t]
+    expr
+;;
+
+let lift_drop_if ~loc ld expr =
+  let ty = strip_attributes#core_type ld.pld_type in
+  Lifted.create ~loc ~prefix:"drop_if" ~ty:[%type: [%t ty] -> Stdlib.Bool.t] expr
+;;
+
+module Of_sexp = struct
+  type t =
+    | Default of expression Lifted.t
+    | Required
+
+  let create ~loc ld =
+    create
+      ~loc
+      [ get_attribute default ~f:(fun { to_lift = default } ->
+          Default (lift_default ~loc ld default))
+      ]
+      ld
+      ~if_no_attribute:Required
+  ;;
+end
+
+module Sexp_of = struct
+  module Drop = struct
+    type t =
+      | No_arg
+      | Compare
+      | Equal
+      | Sexp
+      | Func of expression Lifted.t
+  end
+
+  type t =
+    | Drop_default of Drop.t
+    | Drop_if of expression Lifted.t
+    | Keep
+
+  let create ~loc ld =
+    create
+      ~loc
+      [ get_attribute drop_default ~f:(function
+          | None -> Drop_default No_arg
+          | Some { to_lift = e } -> Drop_default (Func (lift_drop_default ~loc ld e)))
+      ; get_attribute drop_default_equal ~f:(fun () -> Drop_default Equal)
+      ; get_attribute drop_default_compare ~f:(fun () -> Drop_default Compare)
+      ; get_attribute drop_default_sexp ~f:(fun () -> Drop_default Sexp)
+      ; get_attribute drop_if ~f:(fun { to_lift = x } -> Drop_if (lift_drop_if ~loc ld x))
+      ]
+      ld
+      ~if_no_attribute:Keep
+  ;;
+end

unikernel/duniverse/ppx_sexp_conv/expander/record_field_attrs.mli

@@ -0,0 +1,41 @@
+open! Base
+open! Ppxlib
+
+module Generic : sig
+  type 'specific t =
+    | Omit_nil
+    | Sexp_array of core_type
+    | Sexp_bool
+    | Sexp_list of core_type
+    | Sexp_option of core_type
+    | Specific of 'specific
+end
+
+module Of_sexp : sig
+  type t =
+    | Default of expression Lifted.t
+    | Required
+
+  val create : loc:Location.t -> label_declaration -> t Generic.t
+end
+
+module Sexp_of : sig
+  module Drop : sig
+    type t =
+      | No_arg
+      | Compare
+      | Equal
+      | Sexp
+      | Func of expression Lifted.t
+  end
+
+  type t =
+    | Drop_default of Drop.t
+    | Drop_if of expression Lifted.t
+    | Keep
+
+  val create : loc:Location.t -> label_declaration -> t Generic.t
+end
+
+(** Lift the contents of [Attrs.default]. *)
+val lift_default : loc:location -> label_declaration -> expression -> expression Lifted.t

unikernel/duniverse/ppx_sexp_conv/expander/renaming.ml

@@ -0,0 +1,120 @@
+open! Base
+open! Ppxlib
+
+type t =
+  { universal : (Fresh_name.t, string loc) Result.t Map.M(String).t
+  ; existential : bool
+  }
+
+module Binding_kind = struct
+  type t =
+    | Universally_bound of Fresh_name.t
+    | Existentially_bound
+end
+
+let add_universally_bound t name ~prefix =
+  { t with
+    universal =
+      Map.set
+        t.universal
+        ~key:name.txt
+        ~data:(Ok (Fresh_name.create (prefix ^ name.txt) ~loc:name.loc))
+  }
+;;
+
+let binding_kind t var ~loc =
+  match Map.find t.universal var with
+  | None ->
+    if t.existential
+    then Binding_kind.Existentially_bound
+    else Location.raise_errorf ~loc "ppx_sexp_conv: unbound type variable '%s" var
+  | Some (Ok fresh) -> Binding_kind.Universally_bound fresh
+  | Some (Error { loc; txt }) -> Location.raise_errorf ~loc "%s" txt
+;;
+
+(* Return a map translating type variables appearing in the return type of a GADT
+   constructor to their name in the type parameter list.
+
+   For instance:
+
+   {[
+     type ('a, 'b) t = X : 'x * 'y -> ('x, 'y) t
+   ]}
+
+   will produce:
+
+   {v
+     "x" -> Ok "a"
+     "y" -> Ok "b"
+   v}
+
+   If a variable appears twice in the return type it will map to [Error _]. If a
+   variable cannot be mapped to a parameter of the type declaration, it will map to
+   [Error] (for instance [A : 'a -> 'a list t]).
+
+   It returns [original] on user error, to let the typer give the error message *)
+let with_constructor_declaration original cd ~type_parameters:tps =
+  (* Add all type variables of a type to a map. *)
+  let add_typevars =
+    object
+      inherit [t] Ast_traverse.fold as super
+
+      method! core_type ty t =
+        match ty.ptyp_desc with
+        | Ptyp_var var ->
+          let error =
+            { loc = ty.ptyp_loc
+            ; txt = "ppx_sexp_conv: variable is not a parameter of the type constructor"
+            }
+          in
+          { t with universal = Map.set t.universal ~key:var ~data:(Error error) }
+        | _ -> super#core_type ty t
+    end
+  in
+  let aux t tp_name tp_in_return_type =
+    match tp_in_return_type.ptyp_desc with
+    | Ptyp_var var ->
+      let data =
+        let loc = tp_in_return_type.ptyp_loc in
+        if Map.mem t.universal var
+        then Error { loc; txt = "ppx_sexp_conv: duplicate variable" }
+        else (
+          match Map.find original.universal tp_name with
+          | Some result -> result
+          | None -> Error { loc; txt = "ppx_sexp_conv: unbound type parameter" })
+      in
+      { t with universal = Map.set t.universal ~key:var ~data }
+    | _ -> add_typevars#core_type tp_in_return_type t
+  in
+  match cd.pcd_res with
+  | None -> original
+  | Some ty ->
+    (match ty.ptyp_desc with
+     | Ptyp_constr (_, params) ->
+       if List.length params <> List.length tps
+       then original
+       else
+         Stdlib.ListLabels.fold_left2
+           tps
+           params
+           ~init:{ existential = true; universal = Map.empty (module String) }
+           ~f:aux
+     | _ -> original)
+;;
+
+let of_type_declaration decl ~prefix =
+  { existential = false
+  ; universal =
+      List.fold
+        decl.ptype_params
+        ~init:(Map.empty (module String))
+        ~f:(fun map param ->
+          let name = get_type_param_name param in
+          Map.update map name.txt ~f:(function
+            | None -> Ok (Fresh_name.create (prefix ^ name.txt) ~loc:name.loc)
+            | Some _ ->
+              Error { loc = name.loc; txt = "ppx_sexp_conv: duplicate variable" }))
+  }
+;;
+
+let without_type () = { existential = false; universal = Map.empty (module String) }

unikernel/duniverse/ppx_sexp_conv/expander/renaming.mli

@@ -0,0 +1,52 @@
+(* A renaming is a mapping from type variable name to type variable name.
+   In definitions such as:
+
+   type 'a t =
+   | A : <type> -> 'b t
+   | B of 'a
+
+   we generate a function that takes an sexp_of parameter named after 'a, but 'a is not in
+   scope in <type> when handling the constructor A (because A is a gadt constructor).
+   Instead the type variables in scope are the ones defined in the return type of A,
+   namely 'b. There could be less or more type variable in cases such as:
+
+   type _ less = Less : int less
+   type _ more = More : ('a * 'a) more
+
+   If for instance, <type> is ['b * 'c], when we find 'b, we will look for ['b] in the
+   renaming and find ['a] (only in that gadt branch, it could be something else in other
+   branches), at which point we can call the previously bound sexp_of parameter named
+   after 'a.
+   If we can't find a resulting name, like when looking up ['c] in the renaming, then we
+   assume the variable is existentially quantified and treat it as [_] (which is ok,
+   assuming there are no constraints). *)
+open! Base
+open! Ppxlib
+
+type t
+
+(** Renaming for contexts outside a type declaration, such as expression extensions. *)
+val without_type : unit -> t
+
+(** Renaming for a type declaration. Adds [prefix] to bindings for type parameters. *)
+val of_type_declaration : type_declaration -> prefix:string -> t
+
+(** Adds a new name with the given [prefix] for a universally bound type variable. *)
+val add_universally_bound : t -> string loc -> prefix:string -> t
+
+module Binding_kind : sig
+  type t =
+    | Universally_bound of Fresh_name.t
+    | Existentially_bound
+end
+
+(** Looks up the binding for a type variable. *)
+val binding_kind : t -> string -> loc:location -> Binding_kind.t
+
+(** Extends the renaming of a type declaration with GADT context for a constructor
+    declaration, if any. *)
+val with_constructor_declaration
+  :  t
+  -> constructor_declaration
+  -> type_parameters:string list
+  -> t