unikernel/duniverse/ppxlib_jane/.gitignore

@@ -0,0 +1,5 @@
+_build
+*.install
+*.merlin
+_opam
+

unikernel/duniverse/ppxlib_jane/.ocamlformat

@@ -0,0 +1 @@
+profile=janestreet

unikernel/duniverse/ppxlib_jane/CONTRIBUTING.md

@@ -0,0 +1,67 @@
+This repository contains open source software that is developed and
+maintained by [Jane Street][js].
+
+Contributions to this project are welcome and should be submitted via
+GitHub pull requests.
+
+Signing contributions
+---------------------
+
+We require that you sign your contributions. Your signature certifies
+that you wrote the patch or otherwise have the right to pass it on as
+an open-source patch. The rules are pretty simple: if you can certify
+the below (from [developercertificate.org][dco]):
+
+```
+Developer Certificate of Origin
+Version 1.1
+
+Copyright (C) 2004, 2006 The Linux Foundation and its contributors.
+1 Letterman Drive
+Suite D4700
+San Francisco, CA, 94129
+
+Everyone is permitted to copy and distribute verbatim copies of this
+license document, but changing it is not allowed.
+
+
+Developer's Certificate of Origin 1.1
+
+By making a contribution to this project, I certify that:
+
+(a) The contribution was created in whole or in part by me and I
+    have the right to submit it under the open source license
+    indicated in the file; or
+
+(b) The contribution is based upon previous work that, to the best
+    of my knowledge, is covered under an appropriate open source
+    license and I have the right under that license to submit that
+    work with modifications, whether created in whole or in part
+    by me, under the same open source license (unless I am
+    permitted to submit under a different license), as indicated
+    in the file; or
+
+(c) The contribution was provided directly to me by some other
+    person who certified (a), (b) or (c) and I have not modified
+    it.
+
+(d) I understand and agree that this project and the contribution
+    are public and that a record of the contribution (including all
+    personal information I submit with it, including my sign-off) is
+    maintained indefinitely and may be redistributed consistent with
+    this project or the open source license(s) involved.
+```
+
+Then you just add a line to every git commit message:
+
+```
+Signed-off-by: Joe Smith <joe.smith@email.com>
+```
+
+Use your real name (sorry, no pseudonyms or anonymous contributions.)
+
+If you set your `user.name` and `user.email` git configs, you can sign
+your commit automatically with git commit -s.
+
+[dco]: http://developercertificate.org/
+[js]: https://opensource.janestreet.com/

unikernel/duniverse/ppxlib_jane/LICENSE.md

@@ -0,0 +1,21 @@
+The MIT License
+
+Copyright (c) 2023--2024 Jane Street Group, LLC <opensource-contacts@janestreet.com>
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

unikernel/duniverse/ppxlib_jane/Makefile

@@ -0,0 +1,17 @@
+INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),)
+
+default:
+	dune build
+
+install:
+	dune install $(INSTALL_ARGS)
+
+uninstall:
+	dune uninstall $(INSTALL_ARGS)
+
+reinstall: uninstall install
+
+clean:
+	dune clean
+
+.PHONY: default install uninstall reinstall clean

unikernel/duniverse/ppxlib_jane/README.md

@@ -0,0 +1,38 @@
+'`ppxlib_jane`'
+===============
+
+A library for use in ppxes for constructing and matching on ASTs corresponding to the
+augmented parsetree that is recognized by the [Jane Street OCaml compiler][JaneStreetOCaml].
+
+ASTs constructed using this library are compatible with the standard OCaml compiler. Any
+syntax change known to this library is encoded as attributes, and the standard OCaml
+compiler's interpretation of the ASTs constructed by these library (which amounts to
+ignoring the attributes) is reasonable. That is, we only expose "unsurprising" things in
+this library. For example, if you construct an *n*-ary function using this library, the
+standard OCaml compiler will interpret it as *n* nested unary functions in the normal way.
+
+Likewise, ppxes that use this library to match on Jane Street ASTs can also be used with
+the standard OCaml compiler. (The Jane Street AST cases of the match will just never be
+triggered when using the standard OCaml compiler.)
+
+This is how we intend this library to fit into the broader ppx ecosystem:
+
+```
++-------------+       +--------------+      +------------------+
+|             |       |              |      |                  |
+|    ppxes    +------>|    ppxlib    +----->+ compiler libs,   |
+|             |       |              |      | ppxlib_ast, etc. |
++------+------+       +--------------+      |                  |
+       |                                    +---------+--------+
+       |              +---------------+               ^
+       |              |               |               |
+       +------------->+  ppxlib_jane  +---------------+
+                      |               |
+                      +---------------+
+```
+
+That is, there is no dependency between `ppxlib` and `ppxlib_jane`, and ppx authors
+are free to use `ppxlib_jane` if they want to construct AST nodes recognized by the
+Jane Street OCaml compiler.
+
+[JaneStreetOCaml]: https://github.com/ocaml-flambda/flambda-backend

unikernel/duniverse/ppxlib_jane/dune-project

@@ -0,0 +1 @@
+(lang dune 3.11)

unikernel/duniverse/ppxlib_jane/ppxlib_jane.opam

@@ -0,0 +1,22 @@
+opam-version: "2.0"
+version: "v0.17.4"
+maintainer: "Jane Street developers"
+authors: ["Jane Street Group, LLC"]
+homepage: "https://github.com/janestreet/ppxlib_jane"
+bug-reports: "https://github.com/janestreet/ppxlib_jane/issues"
+dev-repo: "git+https://github.com/janestreet/ppxlib_jane.git"
+doc: "https://ocaml.janestreet.com/ocaml-core/latest/doc/ppxlib_jane/index.html"
+license: "MIT"
+build: [
+  ["dune" "build" "-p" name "-j" jobs]
+]
+depends: [
+  "ocaml" {>= "5.3.0"}
+  "dune"   {>= "3.11.0"}
+  "ppxlib" {>= "0.36.0"}
+]
+available: arch != "arm32" & arch != "x86_32"
+synopsis: "Utilities for working with Jane Street AST constructs"
+description: "
+Part of the Jane Street's PPX rewriters collection.
+"

unikernel/duniverse/ppxlib_jane/src/ast_builder.ml

@@ -0,0 +1,273 @@
+open Astlib
+open Ppxlib_ast.Asttypes
+open Ppxlib_ast.Parsetree
+open Stdppx
+include Ast_builder_intf
+include Types
+
+let core_type ptyp_desc ~loc:ptyp_loc =
+  { ptyp_desc; ptyp_loc; ptyp_attributes = []; ptyp_loc_stack = [] }
+;;
+
+module Default = struct
+  include Types
+
+  let mark_type_with_mode_expr modes ty =
+    let attr = Jane_syntax.Mode_expr.attr_of modes in
+    match attr with
+    | None -> ty
+    | Some attr -> { ty with ptyp_attributes = attr :: ty.ptyp_attributes }
+  ;;
+
+  let mode_expr_of_mode ~loc mode =
+    match mode with
+    | None -> Jane_syntax.Mode_expr.empty
+    | Some Local ->
+      let mode = Jane_syntax.Mode_expr.Const.mk "local" loc in
+      { txt = [ mode ]; loc }
+  ;;
+
+  let mark_type_with_mode ~loc mode ty =
+    mark_type_with_mode_expr (mode_expr_of_mode ~loc mode) ty
+  ;;
+
+  let ptyp_arrow ~loc { arg_label; arg_mode; arg_type } { result_mode; result_type } =
+    core_type
+      ~loc
+      (Ptyp_arrow
+         ( arg_label
+         , mark_type_with_mode ~loc arg_mode arg_type
+         , mark_type_with_mode ~loc result_mode result_type ))
+  ;;
+
+  let tarrow ~loc args result =
+    match args with
+    | [] ->
+      raise
+        (Invalid_argument
+           "tarrow: Can't construct a 0-ary arrow, argument list must be nonempty")
+    | _ :: _ ->
+      let result_mode_and_type =
+        let { result_mode; result_type } = result in
+        mark_type_with_mode ~loc result_mode result_type
+      in
+      List.fold_right
+        args
+        ~init:result_mode_and_type
+        ~f:(fun { arg_label; arg_mode; arg_type } arrow_type ->
+        let arg_type = mark_type_with_mode ~loc arg_mode arg_type in
+        core_type ~loc (Ptyp_arrow (arg_label, arg_type, arrow_type)))
+  ;;
+
+  let tarrow_maybe ~loc args result_type =
+    match args with
+    | [] -> result_type
+    | _ :: _ -> tarrow ~loc args { result_mode = None; result_type }
+  ;;
+
+  let get_mode ty =
+    let modes, ptyp_attributes = Jane_syntax.Mode_expr.of_attrs ty.ptyp_attributes in
+    let mode =
+      match (modes.txt : Jane_syntax.Mode_expr.Const.t list :> _ Location.loc list) with
+      | [] -> None
+      | [ { txt = "local"; _ } ] -> Some Local
+      | _ -> raise (Invalid_argument "Unrecognized modes")
+    in
+    mode, { ty with ptyp_attributes }
+  ;;
+
+  let mode_expr_of_modality ~loc cmo ld =
+    match cmo, ld with
+    | None, _ -> Jane_syntax.Mode_expr.empty
+    | Some Global, (None | Some { pld_mutable = Immutable; _ }) ->
+      let mode = Jane_syntax.Mode_expr.Const.mk "global" loc in
+      { txt = [ mode ]; loc }
+    | Some Global, Some { pld_mutable = Mutable; _ } ->
+      raise (Invalid_argument "record fields cannot be marked as both global and mutable")
+  ;;
+
+  let mark_type_with_modality ~loc cmo ty =
+    mark_type_with_mode_expr (mode_expr_of_modality ~loc cmo None) ty
+  ;;
+
+  let mark_label_with_mode_expr modes ld =
+    let pld_type = mark_type_with_mode_expr modes ld.pld_type in
+    { ld with pld_type }
+  ;;
+
+  let mark_label_with_modality ~loc cmo ld =
+    mark_label_with_mode_expr (mode_expr_of_modality ~loc cmo (Some ld)) ld
+  ;;
+
+  let pcstr_tuple ~loc modes_tys =
+    Pcstr_tuple
+      (List.map modes_tys ~f:(fun (mode, ty) -> mark_type_with_modality ~loc mode ty))
+  ;;
+
+  let add_modes_to_label_declarations ~for_ ~loc modes_lds =
+    match modes_lds with
+    | [] -> raise (Invalid_argument (for_ ^ ": records must have at least one field"))
+    | _ :: _ ->
+      List.map modes_lds ~f:(fun (mode, ld) -> mark_label_with_modality ~loc mode ld)
+  ;;
+
+  let pcstr_record ~loc modes_lds =
+    Pcstr_record (add_modes_to_label_declarations ~for_:"pcstr_record" ~loc modes_lds)
+  ;;
+
+  let ptype_record ~loc modes_lds =
+    Ptype_record (add_modes_to_label_declarations ~for_:"ptyp_record" ~loc modes_lds)
+  ;;
+
+  let get_attributes_modality attrs =
+    let modalities, rest = Jane_syntax.Mode_expr.of_attrs attrs in
+    let modality =
+      let modalities =
+        (modalities.txt : Jane_syntax.Mode_expr.Const.t list :> _ Location.loc list)
+      in
+      match modalities with
+      | [] -> None
+      | [ { txt = "global"; _ } ] -> Some Global
+      | _ -> raise (Invalid_argument "Unrecognized modalities")
+    in
+    modality, rest
+  ;;
+
+  let get_tuple_field_modality carg =
+    let modality, ptyp_attributes = get_attributes_modality carg.ptyp_attributes in
+    modality, { carg with ptyp_attributes }
+  ;;
+
+  let get_label_declaration_modality ld =
+    let modality, pld_type = get_tuple_field_modality ld.pld_type in
+    modality, { ld with pld_type }
+  ;;
+
+  let n_ary_function ~loc ~attrs ~params ~ty_constraint ~body =
+    let expr = Jane_syntax.N_ary_functions.expr_of (params, ty_constraint, body) ~loc in
+    match attrs with
+    | [] -> expr
+    | _ :: _ as attrs -> { expr with pexp_attributes = expr.pexp_attributes @ attrs }
+  ;;
+
+  let match_n_ary_function ast =
+    match Jane_syntax.Expression.of_ast ast with
+    | Some (Jexp_n_ary_function (params, ty_constraint, body), attrs) ->
+      Some (params, ty_constraint, body, attrs)
+    | _ -> None
+  ;;
+
+  let unary_function ~loc ?(attrs = []) cases =
+    n_ary_function
+      ~attrs
+      ~params:[]
+      ~ty_constraint:None
+      ~body:(Pfunction_cases (cases, loc, []))
+      ~loc
+  ;;
+
+  let fun_param ~loc arg_label pattern =
+    { pparam_desc = Pparam_val (arg_label, None, pattern); pparam_loc = loc }
+  ;;
+
+  let add_fun_params ~loc ?(attrs = []) new_params body =
+    match new_params with
+    | [] -> body
+    | _ :: _ ->
+      (* If the body is already a function, extend its arity rather than creating a new
+         function.
+      *)
+      (match match_n_ary_function body with
+       | Some (params, ty_constraint, body, existing_attrs) ->
+         let existing_attrs =
+           List.filter existing_attrs ~f:(fun attr ->
+             (* We drop "merlin.loc" attributes inserted by merlin's parser.
+
+                These attributes are always fine to drop -- they're a best-effort attempt
+                to encode extra location information -- and usually not fine to move.
+                That's because merlin expects certain invariants to hold between
+                the location encoded by the "merlin.loc" and locations of sub-ASTs.
+             *)
+             String.( <> ) attr.attr_name.txt "merlin.loc")
+         in
+         n_ary_function
+           ~params:(new_params @ params)
+           ~ty_constraint
+           ~body
+           ~loc
+           ~attrs:(existing_attrs @ attrs)
+       | None ->
+         n_ary_function
+           ~params:new_params
+           ~ty_constraint:None
+           ~body:(Pfunction_body body)
+           ~loc
+           ~attrs)
+  ;;
+
+  let add_fun_param ~loc ?attrs lbl def pat body =
+    add_fun_params
+      ?attrs
+      ~loc
+      [ { pparam_desc = Pparam_val (lbl, def, pat); pparam_loc = pat.ppat_loc } ]
+      body
+  ;;
+
+  let coalesce_fun_arity ast =
+    match match_n_ary_function ast with
+    | None | Some (_, Some _, _, _) | Some (_, _, Pfunction_cases _, _) -> ast
+    | Some (params1, None, Pfunction_body outer_body, outer_attrs) ->
+      (match match_n_ary_function outer_body with
+       | Some (params2, ty_constraint, inner_body, []) ->
+         n_ary_function
+           ~params:(params1 @ params2)
+           ~ty_constraint
+           ~body:inner_body
+           ~loc:ast.pexp_loc
+           ~attrs:outer_attrs
+       | Some (_, _, _, _ :: _) | None -> ast)
+  ;;
+
+  let eabstract ~loc ?(coalesce_fun_arity = true) pats body =
+    let params = List.map pats ~f:(fun pat -> fun_param ~loc:pat.ppat_loc Nolabel pat) in
+    if coalesce_fun_arity
+    then add_fun_params ~loc params body
+    else
+      n_ary_function
+        ~loc
+        ~params
+        ~ty_constraint:None
+        ~body:(Pfunction_body body)
+        ~attrs:[]
+  ;;
+end
+
+module Make (Loc : sig
+  val loc : Location.t
+end) =
+struct
+  include Default
+
+  let loc = Loc.loc
+  let ptyp_arrow arg res : core_type = ptyp_arrow ~loc arg res
+  let tarrow args res : core_type = tarrow ~loc args res
+  let tarrow_maybe args res : core_type = tarrow_maybe ~loc args res
+  let pcstr_tuple fields : constructor_arguments = pcstr_tuple ~loc fields
+  let pcstr_record labels : constructor_arguments = pcstr_record ~loc labels
+  let ptype_record labels : type_kind = ptype_record ~loc labels
+
+  let eabstract ?coalesce_fun_arity a b : expression =
+    eabstract ~loc ?coalesce_fun_arity a b
+  ;;
+
+  let fun_param a b : function_param = fun_param ~loc a b
+  let unary_function ?attrs a : expression = unary_function ~loc ?attrs a
+  let add_fun_param ?attrs a b c d : expression = add_fun_param ~loc ?attrs a b c d
+  let add_fun_params ?attrs a b : expression = add_fun_params ~loc ?attrs a b
+end
+
+let make loc : (module S_with_implicit_loc) =
+  (module Make (struct
+    let loc = loc
+  end))
+;;

unikernel/duniverse/ppxlib_jane/src/ast_builder.mli

@@ -0,0 +1 @@
+include Ast_builder_intf.Ast_builder (** @inline *)

unikernel/duniverse/ppxlib_jane/src/ast_builder_intf.ml

@@ -0,0 +1,244 @@
+open Astlib
+open Ppxlib_ast.Asttypes
+open Ppxlib_ast.Parsetree
+
+module Types = struct
+  (** The modes that can go on function arguments or return types *)
+  type mode = Local (** [local_ ty] *)
+
+  (** Function arguments; a value of this type represents:
+      - [arg_mode arg_type -> ...] when [arg_label] is
+        {{!Asttypes.arg_label.Nolabel}[Nolabel]},
+      - [l:arg_mode arg_type -> ...] when [arg_label] is
+        {{!Asttypes.arg_label.Labelled}[Labelled]}, and
+      - [?l:arg_mode arg_type -> ...] when [arg_label] is
+        {{!Asttypes.arg_label.Optional}[Optional]}. *)
+  type arrow_argument =
+    { arg_label : arg_label
+    ; arg_mode : mode option
+    ; arg_type : core_type
+    }
+
+  (** Function return types; a value of this type represents
+      [... -> result_mode result_type]. *)
+  type arrow_result =
+    { result_mode : mode option
+    ; result_type : core_type
+    }
+
+  (** The modalities that can go on constructor fields *)
+  type modality =
+    | Global (** [C of (..., global_ ty, ...)] or [{ ...; global_ l : ty; ... }]. *)
+
+  (** This type corresponds to [Parsetree.function_param] added in #12236; see the comment
+      below introducing function arity. *)
+  type function_param_desc = Jane_syntax.N_ary_functions.function_param_desc =
+    | Pparam_val of arg_label * expression option * pattern
+        (** In [Pparam_val (lbl, def, pat)]:
+        - [lbl] is the parameter label
+        - [def] is the default argument for an optional parameter
+        - [pat] is the pattern that is matched against the argument.
+          See comment on {!Parsetree.Pexp_fun} for more detail. *)
+    | Pparam_newtype of string loc * Jane_asttypes.jkind_annotation option
+        (** [Pparam_newtype tv] represents a locally abstract type argument [(type tv)] *)
+
+  type function_param = Jane_syntax.N_ary_functions.function_param =
+    { pparam_desc : function_param_desc
+    ; pparam_loc : Location.t
+    }
+end
+
+module type S = sig
+  type 'a with_loc
+
+  (** We expose the types within the specific [Ast_builder.S] modules because those
+      modules are designed to be opened. *)
+  include module type of struct
+    include Types
+  end
+
+  (** Construct an arrow type with the provided argument and result, including the types,
+      modes, and argument label (if any). *)
+  val ptyp_arrow : (arrow_argument -> arrow_result -> core_type) with_loc
+
+  (** Construct a multi-argument arrow type with the provided arguments and result.
+
+      @raise [Invalid_argument] if the input list is empty. *)
+  val tarrow : (arrow_argument list -> arrow_result -> core_type) with_loc
+
+  (** As [tarrow], but will return the result if the input list is empty rather than
+      erroring; this means the result type cannot have a mode annotation. *)
+  val tarrow_maybe : (arrow_argument list -> core_type -> core_type) with_loc
+
+  (** Splits a possibly-mode-annotated function argument or result into a pair of its mode
+      and the unannotated type.  If the resulting mode is [None], then the type is
+      returned unchanged.  *)
+  val get_mode : core_type -> mode option * core_type
+
+  (** Construct a [Pcstr_tuple], a representation for the contents of a tupled variant
+      constructor, that attaches the provided modalities to each field. *)
+  val pcstr_tuple : ((modality option * core_type) list -> constructor_arguments) with_loc
+
+  (** Construct a [Pcstr_record], a representation for the contents of a variant
+      constructor with an inlined record, that attaches the provided modalities to each
+      label.
+
+      @raise [Invalid_argument] if the input list is empty. *)
+  val pcstr_record
+    : ((modality option * label_declaration) list -> constructor_arguments) with_loc
+
+  (** Construct a [Ptype_record], a representation of a record type, that attaches the
+      provided modalities to each label.
+
+      @raise [Invalid_argument] if the input list is empty. *)
+  val ptype_record : ((modality option * label_declaration) list -> type_kind) with_loc
+
+  (** Splits a possibly-modality-annotated field of a tupled variant constructor into a
+      pair of its modality and the unannotated field.  If the resulting mode is [None],
+      then the field is returned unchanged.  *)
+  val get_tuple_field_modality : core_type -> modality option * core_type
+
+  (** Splits a possibly-modality-annotated label declaration into a pair of its modality
+      and the unannotated label declaration.  If the resulting modality is [None], then
+      the label declaration is returned unchanged.  *)
+  val get_label_declaration_modality
+    :  label_declaration
+    -> modality option * label_declaration
+
+  (** Many comments below make reference to the Jane Street compiler's treatment of
+      function arity. These comments refer to a parsetree change made to upstream OCaml in
+      https://github.com/ocaml/ocaml/pull/12236, but that Jane Street has mirrored
+      internally already.
+
+      The treatment of arity can be summarized as follows:
+      - In a previous version of OCaml, a function's runtime arity was inferred at a
+        late stage of the compiler, after typechecking, where it fuses together
+        nested lambdas.
+      - In the new version of OCaml (both upstream OCaml after #12236 and the
+        internal Jane Street compiler), a function's runtime arity is purely a syntactic
+        notion: it's the number of parameters in a [fun x1 ... xn -> body] construct,
+        with some special allowances for function cases.
+
+      Why is arity important? In native code, application sites of a function to [n]
+      syntactic arguments will trigger a fast path (where arguments are passed in
+      registers) only if the function's runtime arity is [n].
+
+      As a result, ppxes must take more care than before to generate functions of the
+      correct arity. Now, a nested function like [fun x -> fun y -> e] has arity 1
+      (returning still another function of arity 1) instead of arity 2. All bindings
+      below that construct functions are documented as to the arity of the returned
+      function.
+
+      Some examples of arity:
+      - 2-ary function: [fun x y -> e]
+      - 1-ary function returning 1-ary function: [fun x -> fun y -> e]
+      - 3-ary function: [fun x y -> function P1 -> e1 | P2 -> e2]
+      - 2-ary function returning 1-ary function: [fun x y -> (function P1 -> e1 | P2 -> e2)]
+      - 2-ary function returning 1-ary function: [fun x -> function P1 -> function P2 -> e]
+
+      Notably, unparenthesized [function] has a special meaning when used as a direct body
+      of [fun]: the [function] becomes part of the arity of the outer [fun]. The same
+      does not apply for multiple nested [function]s, even if they each have a single
+      case; the nested [function]s are treated as unary. (See the last example.)
+  *)
+
+  (** Create a function with unlabeled parameters and an expression body. Like
+      {!Ppxlib.Ast_builder.eapply}, but for constructing functions.
+
+      [coalesce_fun_arity] is relevant for the Jane Street compiler. By default,
+      [coalesce_fun_arity] is [true].
+
+      Suppose there is a call [eabstract pats body ~coalesce_fun_arity]
+      - If [colaesce_fun_arity] is [true], the arity of the returned function
+        is the same as the arity of:
+        [add_fun_params (List.map params ~f:(Fun.param Nolabel)) body]
+      - If [coalesce_fun_arity] is [false], then the arity of the returned function
+        is the length of [pats].
+
+      In other words, [coalesce_fun_arity = true] allows you to build up the arity of
+      an already-constructed function rather than necessarily creating a new function.
+
+  *)
+  val eabstract
+    : (?coalesce_fun_arity:bool -> pattern list -> expression -> expression) with_loc
+
+  (** [unary_function cases] is [function <cases>]. When used with the Jane Street
+      compiler, the function's runtime arity is 1, so the fast path for function
+      application happens only when application sites of the resulting function receive
+      1 argument. To create a function with multiple argument that pattern-matches on
+      the last one, use [add_param] or [add_params] to add more parameters.
+      Alternatively, use [pexp_function] to provide all parameters at once.
+
+      The attributes of the resulting expression will be the [attrs] argument together
+      with any attributes added by the Jane Street compiler.
+  *)
+  val unary_function : (?attrs:attributes -> case list -> expression) with_loc
+
+  (** [fun_param lbl pat] is [Pparam_val (lbl, None, pat)]. This gives a more
+      self-documenting way of constructing the usual case: value parameters without
+      optional argument defaults.
+  *)
+  val fun_param : (arg_label -> pattern -> function_param) with_loc
+
+  (** Say an expression is a "function" if it is a [Pexp_fun] or a [Pexp_function].
+      All functions have parameters and arity.
+
+      Suppose [add_param lbl def pat e ==> e']. Then, letting
+      [param = Pparam_val (lbl, def, pat)],
+      - If [e] is a function with arity [n], then [e'] is a function with arity [n+1].
+        [param] is added at the outermost layer. For example, if
+        [e = fun <params> -> <body>], then [e' = fun <param :: params> -> body].
+        The attributes on the resulting expression will be the [attrs] argument
+        together with any attributes already present on [e].
+      - If [e] is not a function, then [e'] is a function with arity [1], namely:
+        [fun <param> -> <e>]. The attributes of the resulting expression will be the
+        [attrs] argument together with any attributes added by the Jane Street compiler.
+
+  *)
+  val add_fun_param
+    : (?attrs:attributes
+       -> arg_label
+       -> expression option
+       -> pattern
+       -> expression
+       -> expression)
+      with_loc
+
+  (** [add_params params e] is [List.fold_right params ~init:e ~f:add_param].
+      Note the [fold_right]: if [e] is [fun <params'> -> <body>], then
+      [add_params params e] is [fun <params @ params'> -> <body>].
+  *)
+  val add_fun_params
+    : (?attrs:attributes -> function_param list -> expression -> expression) with_loc
+
+  (** This operation is a no-op, except as interpreted by the Jane Street compiler.
+      If [e] is a function with arity [n] with an expression body that itself is
+      a function with arity [m], then [coalesce_fun_arity e] is a function of arity
+      [n + m].
+
+      You should usually call [coalesce_fun_arity] on metaquot fun expressions whose body
+      may be a function, e.g.:
+
+      [coalesce_fun_arity [%expr fun x y -> [%e possibly_function]]]
+  *)
+  val coalesce_fun_arity : expression -> expression
+end
+
+module type S_with_implicit_loc = S with type 'a with_loc := 'a
+module type S_with_explicit_loc = S with type 'a with_loc := loc:Location.t -> 'a
+
+module type Ast_builder = sig
+  (** Jane Street-internal extensions to {!Ppxlib.Ast_builder}. The bindings below
+      ([Default], [Make], etc.) are parallel to bindings exported from
+      [Ppxlib.Ast_builder]. *)
+
+  module type S_with_implicit_loc = S_with_implicit_loc
+
+  module Default : S_with_explicit_loc
+
+  module Make (_ : sig
+    val loc : Location.t
+  end) : S_with_implicit_loc
+
+  val make : Location.t -> (module S_with_implicit_loc)
+end

unikernel/duniverse/ppxlib_jane/src/dune

@@ -0,0 +1,5 @@
+(library
+ (name ppxlib_jane)
+ (public_name ppxlib_jane)
+ (libraries compiler-libs.common ppxlib.ast ppxlib.stdppx ppxlib)
+ (preprocess no_preprocessing))

unikernel/duniverse/ppxlib_jane/src/import_jane_syntax_files.sh

@@ -0,0 +1,45 @@
+#!/bin/bash
+# First, cd into the directory containing the script so the files
+# are imported to the right place regardless of where the script is
+# run from.
+cd "$(dirname "$(realpath -- "$0")")"
+
+if [[ "$1" == "--help" || "$2" == "--help" || "$#" -gt 2 ]]; then
+  echo "Usage: $0 [optional_branch] [optional_url]"
+  echo "Download the Jane Syntax files from a GitHub repository."
+  echo "If a branch and remote are not provided, it will default to the 'main' branch and the flambda-backend GitHub repository."
+  exit 1
+fi
+
+BRANCH=${1:-"main"}
+REMOTE=${2:-"https://github.com/ocaml-flambda/flambda-backend.git"}
+FILE_PATHS=(
+  "ocaml/parsing/jane_syntax.ml"
+  "ocaml/parsing/jane_syntax.mli"
+  "ocaml/parsing/jane_syntax_parsing.ml"
+  "ocaml/parsing/jane_syntax_parsing.mli"
+  "ocaml/parsing/jane_asttypes.ml"
+  "ocaml/parsing/jane_asttypes.mli"
+  "ocaml/utils/language_extension_kernel.mli"
+  "ocaml/utils/language_extension_kernel.ml"
+)
+
+temp_repo=$(mktemp -d)
+git clone --depth 1 --branch "$BRANCH" "$REMOTE" "$temp_repo"
+
+echo "$REMOTE $(git -C "$temp_repo" rev-parse HEAD)" > imported-commit.txt
+
+for file_path in "${FILE_PATHS[@]}"; do
+  {
+    # Disable the warning for record patterns that don't list all their fields.
+    # It's disabled in the compiler.
+    echo '(*_ This file is manually imported from the Jane Street version of the'
+    echo '   OCaml compiler. Don'\''t make changes directly to this file. *)'
+    echo '[@@@ocaml.warning "-missing-record-field-pattern"]'
+    echo 'open! Shadow_compiler_distribution'
+    echo
+    sed < "$temp_repo/$file_path" 's/(\* CR/(* JS-only/g'
+  } > "$(basename "$file_path")"
+done
+
+rm -rf "$temp_repo"

unikernel/duniverse/ppxlib_jane/src/imported-commit.txt

@@ -0,0 +1 @@
+https://github.com/ocaml-flambda/flambda-backend.git 6dd3ac776ba45ba8193d3a78449952404bdb17de

unikernel/duniverse/ppxlib_jane/src/jane_asttypes.ml

@@ -0,0 +1,26 @@
+(*_ This file is manually imported from the Jane Street version of the
+   OCaml compiler. Don't make changes directly to this file. *)
+[@@@ocaml.warning "-missing-record-field-pattern"]
+
+open! Shadow_compiler_distribution
+
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*                   Nick Roberts, Jane Street, New York                  *)
+(*                                                                        *)
+(*   Copyright 2023 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+type const_jkind = string
+
+let jkind_of_string x = x
+let jkind_to_string x = x
+
+type jkind_annotation = const_jkind Location.loc

unikernel/duniverse/ppxlib_jane/src/jane_asttypes.mli

@@ -0,0 +1,42 @@
+(*_ This file is manually imported from the Jane Street version of the
+   OCaml compiler. Don't make changes directly to this file. *)
+[@@@ocaml.warning "-missing-record-field-pattern"]
+
+open! Shadow_compiler_distribution
+
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*               Antal Spector-Zabusky, Jane Street, New York             *)
+(*                                                                        *)
+(*   Copyright 2023 Jane Street Group LLC                                 *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Auxiliary Jane Street extensions to AST types used by parsetree and
+    typedtree.
+
+    This file exists because [Asttypes] is considered part of the parse tree,
+    and we can't modify the parse tree.  This also enables us to build other
+    files with the upstream compiler as long as [jane_asttypes.mli] is present;
+    see Note [Buildable with upstream] in jane_syntax.mli for details on that.
+
+  {b Warning:} this module is unstable and part of
+  {{!Compiler_libs}compiler-libs}.
+
+*)
+
+(** [const_jkind] is private to limit confusion with type variables, which
+    are also strings in the parser.
+*)
+type const_jkind
+
+val jkind_of_string : string -> const_jkind
+val jkind_to_string : const_jkind -> string
+
+type jkind_annotation = const_jkind Location.loc

unikernel/duniverse/ppxlib_jane/src/jane_syntax.mli

@@ -0,0 +1,625 @@
+(*_ This file is manually imported from the Jane Street version of the
+   OCaml compiler. Don't make changes directly to this file. *)
+[@@@ocaml.warning "-missing-record-field-pattern"]
+
+open! Shadow_compiler_distribution
+
+(** Syntax for Jane Street's novel syntactic features.  This module provides
+    three things:
+
+    1. First-class ASTs for all syntax introduced by our language extensions,
+       plus one for built-in features; these are split out into a different
+       module each ([Comprehensions], etc.).
+
+    2. A first-class AST for each OCaml AST, unifying all our novel syntactic
+       features in modules named after the syntactic category
+       ([Expression.t], etc.).
+
+    3. A way to interpret these values as terms of the coresponding OCaml ASTs,
+       and to match on terms of those OCaml ASTs to see if they're terms from
+       our novel syntax.
+
+    We keep our novel syntax separate so that we can avoid having to modify the
+    existing AST, as this would break compatibility with every existing ppx and
+    other such tooling.
+
+    For details on the rationale behind this approach (and for some of the gory
+    details), see [Jane_syntax_parsing]. *)
+
+(******************************************************************************)
+
+(* Note [Buildable with upstream]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+   We want to make sure that the various [Jane_*] modules, along with
+   [Language_extension_kernel] and a small stub for [Language_extension], are
+   buildable with the upstream compiler and compiler-libs.  This allows us to
+   import these files into compatibility libraries such as
+   {{:https://github.com/janestreet/ppxlib_jane}ppxlib_jane}.  We have CI tests
+   which ensure that this property is maintained.
+
+   It is possible that at some point we'll really need to depend on new
+   functionality we provide elsewhere in the compiler; at that point, we can
+   look into providing stub implementations of these modules for use with the
+   upstream compiler instead.  For now, though, this is sufficient.
+*)
+
+(*********************************************)
+(* Individual features *)
+
+(** The ASTs for list and array comprehensions *)
+module Comprehensions : sig
+  type iterator =
+    | Range of
+        { start : Parsetree.expression
+        ; stop : Parsetree.expression
+        ; direction : Asttypes.direction_flag
+        }
+        (** "= START to STOP" (direction = Upto)
+        "= START downto STOP" (direction = Downto) *)
+    | In of Parsetree.expression (** "in EXPR" *)
+
+  (* In [Typedtree], the [pattern] moves into the [iterator]. *)
+
+  (** [@...] PAT (in/=) ... *)
+  type clause_binding =
+    { pattern : Parsetree.pattern
+    ; iterator : iterator
+    ; attributes : Parsetree.attribute list
+    }
+
+  type clause =
+    | For of clause_binding list
+        (** "for PAT (in/=) ... and PAT (in/=) ... and ..."; must be nonempty *)
+    | When of Parsetree.expression (** "when EXPR" *)
+
+  type comprehension =
+    { body : Parsetree.expression (** The body/generator of the comprehension *)
+    ; clauses : clause list (** The clauses of the comprehension; must be nonempty *)
+    }
+
+  type expression =
+    | Cexp_list_comprehension of comprehension (** [BODY ...CLAUSES...] *)
+    | Cexp_array_comprehension of Asttypes.mutable_flag * comprehension
+        (** [|BODY ...CLAUSES...|] (flag = Mutable)
+        [:BODY ...CLAUSES...:] (flag = Immutable)
+          (only allowed with [-extension immutable_arrays]) *)
+
+  val expr_of : loc:Location.t -> expression -> Parsetree.expression
+end
+
+(** The ASTs for immutable arrays.  When we merge this upstream, we'll merge
+    these into the existing [P{exp,pat}_array] constructors by adding a
+    [mutable_flag] argument (just as we did with [T{exp,pat}_array]). *)
+module Immutable_arrays : sig
+  type expression =
+    | Iaexp_immutable_array of Parsetree.expression list (** [: E1; ...; En :] *)
+
+  type pattern =
+    | Iapat_immutable_array of Parsetree.pattern list (** [: P1; ...; Pn :] **)
+
+  val expr_of : loc:Location.t -> expression -> Parsetree.expression
+  val pat_of : loc:Location.t -> pattern -> Parsetree.pattern
+end
+
+module Mode_expr : sig
+  (** [Mode_expr] appears in several places:
+  - let local_ x = ...
+  - local_ exp
+  - local string -> string
+  - {global_ x : int}
+
+  Note that in the first two cases, axes other than locality are not specified;
+  in the second case, other axes are defaulted to legacy. In the last case, we
+  are specifying modalities.
+
+  In the future the three annotations will be quite different, but for now they
+  are all lists of modes/modalities. [Typemode] has the three different
+  interpretations of the annotation.
+
+  (TODO: in the future we will have mutable(...), which is similar to the second
+  occurrence above and should be covered by this module)
+  *)
+
+  module Const : sig
+    (** Constant modes *)
+
+    type raw = string
+
+    (** Represent a user-written mode constant, containing a string and its
+        location *)
+    type t = private raw Location.loc
+
+    (** Constructs a mode constant mode *)
+    val mk : string -> Location.t -> t
+  end
+
+  type t = Const.t list Location.loc
+
+  (** The empty mode expression. *)
+  val empty : t
+
+  (** The mode expression containing a single mode constant. *)
+  val singleton : Const.t -> t
+
+  (** The string used to mark extensions as containing mode expressions. *)
+  val extension_name : string
+
+  (** The string used to mark attributes as containing mode expressions. *)
+  val attribute_name : string
+
+  (** Extract the mode attribute (if any) from a list of attributes; also
+      returns the rest of the attributes; Raises if multiple relevant attributes
+      are found *)
+  val extract_attr
+    :  Parsetree.attributes
+    -> Parsetree.attribute option * Parsetree.attributes
+
+  (** Encode a mode expression into a [attribute]. If the expression is safe to
+      empty (and thus safe to ignore), returns [None]. *)
+  val attr_of : t -> Parsetree.attribute option
+
+  (** Given a list of attributes, extracts the mode expression and returns the
+      rest of attributes. Raises if multiple relevant attributes are found.
+      Raises if attributes encodes empty mode expression *)
+  val maybe_of_attrs : Parsetree.attributes -> t option * Parsetree.attributes
+
+  (* Similar to [maybe_of_attrs], but default to [empty] if no relevant
+      attribute is found. *)
+  val of_attrs : Parsetree.attributes -> t * Parsetree.attributes
+
+  (** Encodes a mode expression into a [payload]. If the expression is safe to
+      ignore (i.e. empty), returns [None]. *)
+  val payload_of : t -> Parsetree.payload option
+
+  (** Decode a mode expression from a [payload] whose location is [loc]. Raises
+      if the payload encodes an empty mode expression. *)
+  val of_payload : loc:Location.t -> Parsetree.payload -> t
+
+  (** In some cases, a single mode expression appears twice in the parsetree;
+      one of them needs to be made ghost to make our internal tools happy. *)
+  val ghostify : t -> t
+end
+
+module N_ary_functions : sig
+  (** These types use the [P] prefix to match how they are represented in the
+      upstream compiler *)
+
+  type function_param_desc =
+    | Pparam_val of Asttypes.arg_label * Parsetree.expression option * Parsetree.pattern
+        (** [Pparam_val (lbl, exp0, P)] represents the parameter:
+        - [P]
+          when [lbl] is {{!Asttypes.arg_label.Nolabel}[Nolabel]}
+          and [exp0] is [None]
+        - [~l:P]
+          when [lbl] is {{!Asttypes.arg_label.Labelled}[Labelled l]}
+          and [exp0] is [None]
+        - [?l:P]
+          when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]}
+          and [exp0] is [None]
+        - [?l:(P = E0)]
+          when [lbl] is {{!Asttypes.arg_label.Optional}[Optional l]}
+          and [exp0] is [Some E0]
+
+        Note: If [E0] is provided, only
+        {{!Asttypes.arg_label.Optional}[Optional]} is allowed.
+    *)
+    | Pparam_newtype of string Asttypes.loc * Jane_asttypes.jkind_annotation option
+        (** [Pparam_newtype (x, jkind)] represents the parameter [(type x)].
+        [x] carries the location of the identifier, whereas [pparam_loc] is
+        the location of the [(type x)] as a whole.
+
+        [jkind] is the same as [Lexp_newtype]'s jkind.
+
+        Multiple parameters [(type a b c)] are represented as multiple
+        [Pparam_newtype] nodes, let's say:
+
+        {[ [ { pparam_desc = Pparam_newtype (a, _); pparam_loc = loc };
+             { pparam_desc = Pparam_newtype (b, _); pparam_loc = loc };
+             { pparam_desc = Pparam_newtype (c, _); pparam_loc = loc };
+           ]
+        ]}
+
+        Here, [loc] gives the location of [(type a b c)], but is marked as a
+        ghost location. The locations on [a], [b], [c], correspond to the
+        variables [a], [b], and [c] in the source code.
+    *)
+
+  type function_param =
+    { pparam_desc : function_param_desc
+    ; pparam_loc : Location.t
+    }
+
+  (** The mode annotation placed on a function let-binding when the function
+      has a type constraint on the body, e.g.
+      [let local_ f x : int -> int = ...].
+  *)
+  type function_constraint =
+    { mode_annotations : Mode_expr.t
+    ; type_constraint : Parsetree.type_constraint
+    }
+
+  (** [([P1; ...; Pn], C, body)] represents any construct
+      involving [fun] or [function], including:
+      - [fun P1 ... Pn -> E]
+        when [body = Pfunction_body E]
+      - [fun P1 ... Pn -> function p1 -> e1 | ... | pm -> em]
+        when [body = Pfunction_cases [ p1 -> e1; ...; pm -> em ]]
+
+      [C] represents a type constraint or coercion placed immediately
+      before the arrow, e.g. [fun P1 ... Pn : t1 :> t2 -> ...]
+      when [C = Some (Pcoerce (Some t1, t2))].
+
+      A function must have parameters. [Pexp_function (params, _, body)] must
+      have non-empty [params] or a [Pfunction_cases _] body.
+  *)
+  type expression = function_param list * function_constraint option * Parsetree.function_body
+
+  val expr_of : loc:Location.t -> expression -> Parsetree.expression
+end
+
+(** The ASTs for labeled tuples. When we merge this upstream, we'll replace
+    existing [P{typ,exp,pat}_tuple] constructors with these. *)
+module Labeled_tuples : sig
+  (** [tl] represents a product type:
+          - [T1 * ... * Tn]       when [tl] is [(None,T1);...;(None,Tn)]
+          - [L1:T1 * ... * Ln:Tn] when [tl] is [(Some L1,T1);...;(Some Ln,Tn)]
+          - A mix, e.g. [L1:T1,T2] when [tl] is [(Some L1,T1);(None,T2)]
+
+          Invariant: [n >= 2].
+      *)
+  type core_type = (string option * Parsetree.core_type) list
+
+  (** [el] represents
+          - [(E1, ..., En)]
+              when [el] is [(None, E1);...;(None, En)]
+          - [(~L1:E1, ..., ~Ln:En)]
+              when [el] is [(Some L1, E1);...;(Some Ln, En)]
+          - A mix, e.g.:
+              [(~L1:E1, E2)] when [el] is [(Some L1, E1); (None, E2)]
+
+          Invariant: [n >= 2].
+      *)
+  type expression = (string option * Parsetree.expression) list
+
+  (** [(pl, Closed)] represents
+          - [(P1, ..., Pn)]       when [pl] is [(None, P1);...;(None, Pn)]
+          - [(L1:P1, ..., Ln:Pn)] when [pl] is
+                                              [(Some L1, P1);...;(Some Ln, Pn)]
+          - A mix, e.g. [(L1:P1, P2)] when [pl] is [(Some L1, P1);(None, P2)]
+          - If pattern is open, then it also ends in a [..]
+
+        Invariant:
+        - If Closed, [n >= 2].
+        - If Open, [n >= 1].
+      *)
+  type pattern = (string option * Parsetree.pattern) list * Asttypes.closed_flag
+
+  (** Embeds the core type in Jane Syntax only if there are any labels.
+      Otherwise, returns a normal [Ptyp_tuple].
+  *)
+  val typ_of : loc:Location.t -> core_type -> Parsetree.core_type
+
+  (** Embeds the expression in Jane Syntax only if there are any labels.
+      Otherwise, returns a normal [Pexp_tuple].
+  *)
+  val expr_of : loc:Location.t -> expression -> Parsetree.expression
+
+  (** Embeds the pattern in Jane Syntax only if there are any labels or
+      if the pattern is open. Otherwise, returns a normal [Ppat_tuple].
+  *)
+  val pat_of : loc:Location.t -> pattern -> Parsetree.pattern
+end
+
+(** The ASTs for [include functor].  When we merge this upstream, we'll merge
+    these into the existing [P{sig,str}_include] constructors (similar to what
+    we did with [T{sig,str}_include], but without depending on typechecking). *)
+module Include_functor : sig
+  type signature_item = Ifsig_include_functor of Parsetree.include_description
+  type structure_item = Ifstr_include_functor of Parsetree.include_declaration
+
+  val sig_item_of : loc:Location.t -> signature_item -> Parsetree.signature_item
+  val str_item_of : loc:Location.t -> structure_item -> Parsetree.structure_item
+end
+
+(** The ASTs for module type strengthening. *)
+module Strengthen : sig
+  type module_type =
+    { mty : Parsetree.module_type
+    ; mod_id : Astlib.Longident.t Location.loc
+    }
+
+  val mty_of : loc:Location.t -> module_type -> Parsetree.module_type
+end
+
+(** The ASTs for jkinds and other unboxed-types features *)
+module Layouts : sig
+  type constant =
+    | Float of string * char option
+    | Integer of string * char
+
+  type nonrec expression =
+    (* examples: [ #2.0 ] or [ #42L ] *)
+    (* This is represented as an attribute wrapping a [Pexp_constant] node. *)
+    | Lexp_constant of constant
+    (* [fun (type a : immediate) -> ...] *)
+    (* This is represented as an attribute wrapping a [Pexp_newtype] node. *)
+    | Lexp_newtype of
+        string Location.loc * Jane_asttypes.jkind_annotation * Parsetree.expression
+
+  type nonrec pattern =
+    (* examples: [ #2.0 ] or [ #42L ] *)
+    (* This is represented as an attribute wrapping a [Ppat_constant] node. *)
+    | Lpat_constant of constant
+
+  type nonrec core_type =
+    (* ['a : immediate] or [_ : float64] *)
+    (* This is represented by an attribute wrapping either a [Ptyp_any] or
+       a [Ptyp_var] node. *)
+    | Ltyp_var of
+        { name : string option
+        ; jkind : Jane_asttypes.jkind_annotation
+        }
+    (* [('a : immediate) 'b 'c ('d : value). 'a -> 'b -> 'c -> 'd] *)
+    (* This is represented by an attribute wrapping a [Ptyp_poly] node. *)
+    (* This is used instead of [Ptyp_poly] only where there is at least one
+       actual jkind annotation. If there is a polytype with no jkind
+       annotations at all, [Ptyp_poly] is used instead. This saves space in the
+       parsed representation and guarantees that we don't accidentally try to
+       require the layouts extension. *)
+    | Ltyp_poly of
+        { bound_vars : (string Location.loc * Jane_asttypes.jkind_annotation option) list
+        ; inner_type : Parsetree.core_type
+        }
+    (* [ty as ('a : immediate)] *)
+    (* This is represented by an attribute wrapping either a [Ptyp_alias] node
+       or, in the [ty as (_ : jkind)] case, the annotated type itself, with no
+       intervening [type_desc]. *)
+    | Ltyp_alias of
+        { aliased_type : Parsetree.core_type
+        ; name : string option
+        ; jkind : Jane_asttypes.jkind_annotation
+        }
+
+  type nonrec extension_constructor =
+    (* [ 'a ('b : immediate) ('c : float64). 'a * 'b * 'c -> exception ] *)
+    (* This is represented as an attribute on a [Pext_decl] node. *)
+    (* Like [Ltyp_poly], this is used only when there is at least one jkind
+       annotation. Otherwise, we will have a [Pext_decl]. *)
+    | Lext_decl of
+        (string Location.loc * Jane_asttypes.jkind_annotation option) list
+        * Parsetree.constructor_arguments
+        * Parsetree.core_type option
+
+  module Pprint : sig
+    val const_jkind : Format_doc.formatter -> Jane_asttypes.const_jkind -> unit
+    val jkind_annotation : Format_doc.formatter -> Jane_asttypes.jkind_annotation -> unit
+  end
+
+  val expr_of : loc:Location.t -> expression -> Parsetree.expression
+  val pat_of : loc:Location.t -> pattern -> Parsetree.pattern
+  val type_of : loc:Location.t -> core_type -> Parsetree.core_type
+
+  val extension_constructor_of
+    :  loc:Location.t
+    -> name:string Location.loc
+    -> ?info:Docstrings.info
+    -> ?docs:Docstrings.docs
+    -> extension_constructor
+    -> Parsetree.extension_constructor
+
+  (** See also [Ast_helper.Type.constructor], which is a direct inspiration for
+      the interface here. *)
+  val constructor_declaration_of
+    :  loc:Location.t
+    -> attrs:Parsetree.attributes
+    -> info:Docstrings.info
+    -> vars_jkinds:(string Location.loc * Jane_asttypes.jkind_annotation option) list
+    -> args:Parsetree.constructor_arguments
+    -> res:Parsetree.core_type option
+    -> string Location.loc
+    -> Parsetree.constructor_declaration
+
+  (** Extract the jkinds from a [constructor_declaration]; returns leftover
+      attributes along with the annotated variables. Unlike other pieces
+      of jane-syntax, users of this function will still have to process
+      the remaining pieces of the original [constructor_declaration]. *)
+  val of_constructor_declaration
+    :  Parsetree.constructor_declaration
+    -> ((string Location.loc * Jane_asttypes.jkind_annotation option) list
+       * Parsetree.attributes)
+       option
+
+  (** See also [Ast_helper.Type.mk], which is a direct inspiration for
+      the interface here. *)
+  val type_declaration_of
+    :  loc:Location.t
+    -> attrs:Parsetree.attributes
+    -> docs:Docstrings.docs
+    -> text:Docstrings.text option
+    -> params:(Parsetree.core_type * (Asttypes.variance * Asttypes.injectivity)) list
+    -> cstrs:(Parsetree.core_type * Parsetree.core_type * Location.t) list
+    -> kind:Parsetree.type_kind
+    -> priv:Asttypes.private_flag
+    -> manifest:Parsetree.core_type option
+    -> jkind:Jane_asttypes.jkind_annotation option
+    -> string Location.loc
+    -> Parsetree.type_declaration
+
+  (** Extract the jkind annotation from a [type_declaration]; returns
+      leftover attributes. Similar to [of_constructor_declaration] in the
+      sense that users of this function will have to process the remaining
+      pieces of the original [type_declaration].
+  *)
+  val of_type_declaration
+    :  Parsetree.type_declaration
+    -> (Jane_asttypes.jkind_annotation * Parsetree.attributes) option
+end
+
+(******************************************)
+(* General facility, which we export *)
+
+(** The module type of our extended ASTs for our novel syntax, instantiated once
+    for each syntactic category.  We tend to call the pattern-matching functions
+    here with unusual indentation, not indenting the [None] branch further so as
+    to avoid merge conflicts with upstream. *)
+module type AST = sig
+  (** The AST for all our Jane Street syntax; one constructor per feature that
+      extends the given syntactic category.  Some extensions are handled
+      separately and thus are not listed here.
+
+      This type will be something like [jane_syntax_ast * Parsetree.attributes]
+      in cases where the Jane Syntax encoding of the AST uses attributes. In
+      these cases, the [Parsetree.attributes] are the *rest* of the attributes
+      after removing Jane Syntax-related attributes. Callers of [of_ast] should
+      refer to these attributes rather than, for example, [pexp_attributes].
+  *)
+  type t
+
+  (** The corresponding OCaml AST *)
+  type ast
+
+  (** Given an OCaml AST node, check to see if it corresponds to an embedded
+      term from our novel syntax.  If it does, as long as the feature isn't a
+      disabled language extension, then return it; if it's not a piece of novel
+      syntax, return [None]; if it's an embedded term from a disabled language
+      extension, raise an error.
+
+      AN IMPORTANT NOTE: The design of this function is careful to make merge
+      conflicts with upstream less likely: we want no edits at all -- not even
+      indentation -- to surrounding code. This is why we return a [t option],
+      not some structure that could include the [ast_desc] if there is no
+      extension.
+
+      Indentation: we *do not change the indentation level* when we match on
+      this function's result!  E.g. from [type_expect_] in [typecore.ml]:
+
+      {[
+        match Jane_syntax.Expression.of_ast sexp with
+        | Some jexp ->
+            type_expect_jane_syntax
+              ~loc
+              ~env
+              ~expected_mode
+              ~ty_expected
+              ~explanation
+              ~attributes:sexp.pexp_attributes
+              jexp
+        | None      -> match sexp.pexp_desc with
+        | Pexp_ident lid ->
+            let path, mode, desc, kind = type_ident env ~recarg lid in
+            (* ... *)
+        | Pexp_constant(Pconst_string (str, _, _) as cst) ->
+            register_allocation expected_mode;
+            (* ... *)
+        | (* ... *)
+        | Pexp_unreachable ->
+            re { exp_desc = Texp_unreachable;
+                 exp_loc = loc; exp_extra = [];
+                 exp_type = instance ty_expected;
+                 exp_mode = expected_mode.mode;
+                 exp_attributes = sexp.pexp_attributes;
+                 exp_env = env }
+      ]}
+
+      Note that we match on the result of this function, forward to
+      [type_expect_jane_syntax] if we get something, and otherwise do the real
+      match on [sexp.pexp_desc] *without going up an indentation level*.  This
+      is important to reduce the number of merge conflicts. *)
+  val of_ast : ast -> t option
+end
+
+(******************************************)
+(* Individual syntactic categories *)
+
+(** Novel syntax in types *)
+module Core_type : sig
+  type t =
+    | Jtyp_layout of Layouts.core_type
+    | Jtyp_tuple of Labeled_tuples.core_type
+
+  include AST with type t := t * Parsetree.attributes and type ast := Parsetree.core_type
+
+  val core_type_of
+    :  loc:Location.t
+    -> attrs:Parsetree.attributes
+    -> t
+    -> Parsetree.core_type
+end
+
+(** Novel syntax in constructor arguments; this isn't a core AST type,
+    but captures where [global_] lives *)
+module Constructor_argument : sig
+  type t = |
+
+  include AST with type t := t * Parsetree.attributes and type ast := Parsetree.core_type
+end
+
+(** Novel syntax in expressions *)
+module Expression : sig
+  type t =
+    | Jexp_comprehension of Comprehensions.expression
+    | Jexp_immutable_array of Immutable_arrays.expression
+    | Jexp_layout of Layouts.expression
+    | Jexp_n_ary_function of N_ary_functions.expression
+    | Jexp_tuple of Labeled_tuples.expression
+
+  include AST with type t := t * Parsetree.attributes and type ast := Parsetree.expression
+
+  val expr_of : loc:Location.t -> attrs:Parsetree.attributes -> t -> Parsetree.expression
+end
+
+(** Novel syntax in patterns *)
+module Pattern : sig
+  type t =
+    | Jpat_immutable_array of Immutable_arrays.pattern
+    | Jpat_layout of Layouts.pattern
+    | Jpat_tuple of Labeled_tuples.pattern
+
+  include AST with type t := t * Parsetree.attributes and type ast := Parsetree.pattern
+
+  val pat_of : loc:Location.t -> attrs:Parsetree.attributes -> t -> Parsetree.pattern
+end
+
+(** Novel syntax in module types *)
+module Module_type : sig
+  type t = Jmty_strengthen of Strengthen.module_type
+
+  include
+    AST with type t := t * Parsetree.attributes and type ast := Parsetree.module_type
+
+  val mty_of : loc:Location.t -> attrs:Parsetree.attributes -> t -> Parsetree.module_type
+end
+
+(** Novel syntax in signature items *)
+module Signature_item : sig
+  type t = Jsig_include_functor of Include_functor.signature_item
+
+  include AST with type t := t and type ast := Parsetree.signature_item
+end
+
+(** Novel syntax in structure items *)
+module Structure_item : sig
+  type t = Jstr_include_functor of Include_functor.structure_item
+
+  include AST with type t := t and type ast := Parsetree.structure_item
+end
+
+(** Novel syntax in extension constructors *)
+module Extension_constructor : sig
+  type t = Jext_layout of Layouts.extension_constructor
+
+  include
+    AST
+      with type t := t * Parsetree.attributes
+       and type ast := Parsetree.extension_constructor
+
+  val extension_constructor_of
+    :  loc:Location.t
+    -> name:string Location.loc
+    -> attrs:Parsetree.attributes
+    -> ?info:Docstrings.info
+    -> ?docs:Docstrings.docs
+    -> t
+    -> Parsetree.extension_constructor
+end

unikernel/duniverse/ppxlib_jane/src/jane_syntax_parsing.ml

@@ -0,0 +1,866 @@
+(*_ This file is manually imported from the Jane Street version of the
+   OCaml compiler. Don't make changes directly to this file. *)
+[@@@ocaml.warning "-missing-record-field-pattern"]
+
+open! Shadow_compiler_distribution
+
+(** As mentioned in the .mli file, there are some gory details around the
+    particular translation scheme we adopt for moving to and from OCaml ASTs
+    ([Parsetree.expression], etc.).  The general idea is that we adopt a scheme
+    where each novel piece of syntax is represented using one of two embeddings:
+
+    1. As an AST item carrying an attribute. The AST item serves as the "body"
+      of the syntax indicated by the attribute.
+    2. As a pair of an extension node and an AST item that serves as the "body".
+       Here, the "pair" is embedded as a pair-like construct in the relevant AST
+       category, e.g. [include sig [%jane.ERASABILITY.EXTNAME];; BODY end] for
+       signature items.
+
+    In particular, for an language extension named [EXTNAME] (i.e., one that is
+    enabled by [-extension EXTNAME] on the command line), the attribute (if
+    used) must be [[@jane.ERASABILITY.EXTNAME]], and the extension node (if
+    used) must be [[%jane.ERASABILITY.EXTNAME]]. For built-in syntax, we use
+    [_builtin] instead of an language extension name.
+
+    The [ERASABILITY] component indicates to tools such as ocamlformat and
+    ppxlib whether or not the attribute is erasable. See the documentation of
+    [Erasability] for more information on how tools make use of this
+    information.
+
+    In the below example, we use attributes an examples, but it applies equally
+    to extensions. We also provide utilities for further desugaring similar
+    applications where the embeddings have the longer form
+    [[@jane.ERASABILITY.FEATNAME.ID1.ID2.….IDn]] (with the outermost one being
+    the [n = 0] case), as these might be used inside the [EXPR]. (For example,
+    within the outermost [[@jane.non_erasable.comprehensions]] term for list and
+    array comprehensions, we can also use
+    [[@jane.non_erasable.comprehensions.list]],
+    [[@jane.non_erasable.comprehensions.array]],
+    [[@jane.non_erasable.comprehensions.for.in]], etc.).
+
+    As mentioned, we represent terms as a "pair" and don't use the extension
+    node or attribute payload; this is so that ppxen can see inside these
+    extension nodes or attributes. If we put the subexpressions inside the
+    payload, then we couldn't write something like [[[%string "Hello, %{x}!"]
+    for x in names]], as [ppx_string] wouldn't traverse inside the payload to
+    find the [[%string]] extension node.
+
+    Our novel syntactic features are of course allowed to impose extra
+    constraints on what legal bodies are; we're also happy for this translation
+    to error in various ways on malformed input, since nobody should ever be
+    writing these forms directly.  They're just an implementation detail.
+
+    See modules of type AST below to see how different syntactic categories
+    are represented. For example, expressions are encoded using an attribute.
+
+    We provide one module per syntactic category (e.g., [Expression]), of module
+    type [AST].  They also provide some simple machinery for working with the
+    general [@jane.ERASABILITY.FEATNAME.ID1.ID2.….IDn] wrapped forms. To
+    construct one, we provide [make_jane_syntax]; to destructure one, we provide
+    [match_jane_syntax] (which we expose via [make_of_ast]). Users of this
+    module still have to write the transformations in both directions for all
+    new syntax, lowering it to extension nodes or attributes and then lifting it
+    back out. *)
+
+(** How did we choose between using the attribute embedding and the extension
+    node embedding for a particular syntactic category?
+
+    Generally, we prefer the attribute embedding: it's more compatible with
+    ppxes that aren't aware of Jane Syntax. (E.g., if a type looks like a tuple,
+    it truly is a tuple and not an extension node embedding.)
+
+    We can't apply the attribute embedding everywhere because some syntactic
+    categories, like structure items, don't carry attributes. For these, we
+    use extension nodes.
+
+    However, the attribute embedding is more inconvenient in some ways than
+    the extension node embedding. For example, the attribute embedding requires
+    callers to strip out Jane Syntax-related attributes from the attribute list
+    before processing it. We've tried to make this obvious from the signature
+    of, say, [Jane_syntax.Expression.of_ast], but this is somewhat more
+    inconvenient than just operating on the [expr_desc]. Nonetheless, because
+    of the advantages with ppxlib interoperability, we've opted for the
+    attribute embedding where possible.
+*)
+
+open Parsetree
+
+(** We carefully regulate which bindings we import from [Language_extension]
+    to ensure that we can import this file into the Jane Street internal
+    repo with no changes.
+*)
+module Language_extension = struct
+  include Language_extension_kernel
+
+  include (
+    Language_extension : Language_extension_kernel.Language_extension_for_jane_syntax)
+end
+
+(******************************************************************************)
+
+module Feature : sig
+  type t =
+    | Language_extension : _ Language_extension.t -> t
+    | Builtin
+
+  type error =
+    | Disabled_extension : _ Language_extension.t -> error
+    | Unknown_extension of string
+
+  val describe_uppercase : t -> string
+  val extension_component : t -> string
+  val of_component : string -> (t, error) result
+  val is_erasable : t -> bool
+end = struct
+  type t =
+    | Language_extension : _ Language_extension.t -> t
+    | Builtin
+
+  type error =
+    | Disabled_extension : _ Language_extension.t -> error
+    | Unknown_extension of string
+
+  let builtin_component = "_builtin"
+
+  let describe_uppercase = function
+    | Language_extension ext ->
+      "The extension \"" ^ Language_extension.to_string ext ^ "\""
+    | Builtin -> "Built-in syntax"
+  ;;
+
+  let extension_component = function
+    | Language_extension ext -> Language_extension.to_string ext
+    | Builtin -> builtin_component
+  ;;
+
+  let of_component str =
+    if String.equal str builtin_component
+    then Ok Builtin
+    else (
+      match Language_extension.of_string str with
+      | Some (Pack ext) ->
+        if Language_extension.is_enabled ext
+        then Ok (Language_extension ext)
+        else Error (Disabled_extension ext)
+      | None -> Error (Unknown_extension str))
+  ;;
+
+  let is_erasable = function
+    | Language_extension ext -> Language_extension.is_erasable ext
+    (* Builtin syntax changes don't involve additions or changes to concrete
+       syntax and are always erasable.
+    *)
+    | Builtin -> true
+  ;;
+end
+
+(** Was this embedded as an [[%extension_node]] or an [[@attribute]]?  Not
+    exported. Used only for error messages. *)
+module Embedding_syntax = struct
+  type t =
+    | Extension_node
+    | Attribute
+
+  let name = function
+    | Extension_node -> "extension node"
+    | Attribute -> "attribute"
+  ;;
+
+  let name_indefinite = function
+    | Extension_node -> "an extension node"
+    | Attribute -> "an attribute"
+  ;;
+
+  let name_plural = function
+    | Extension_node -> "extension nodes"
+    | Attribute -> "attributes"
+  ;;
+
+  let pp ppf (t, name) =
+    let sigil =
+      match t with
+      | Extension_node -> "%"
+      | Attribute -> "@"
+    in
+    Format_doc.fprintf ppf "[%s%s]" sigil name
+  ;;
+end
+
+(******************************************************************************)
+
+module Misnamed_embedding_error = struct
+  type t =
+    | No_erasability
+    | No_feature
+    | Unknown_erasability of string
+
+  let to_string = function
+    | No_erasability -> "Missing erasability and feature components"
+    | No_feature -> "Missing a feature component"
+    | Unknown_erasability str ->
+      Printf.sprintf "Unrecognized component where erasability was expected: `%s'" str
+  ;;
+end
+
+(** The component of an attribute or extension name that identifies whether or
+    not the embedded syntax is *erasable*; that is, whether or not the
+    upstream OCaml compiler can safely interpret the AST while ignoring the
+    attribute or extension.  (This means that syntax encoded as extension
+    nodes should always be non-erasable.)  Tools that consume the parse tree
+    we generate can make use of this information; for instance, ocamlformat
+    will use it to guide how we present code that can be run with both our
+    compiler and the upstream compiler, and ppxlib can use it to decide
+    whether it's ok to allow ppxes to construct syntax that uses this
+    emedding.  In particular, the upstream version of ppxlib will allow ppxes
+    to produce [[@jane.erasable.*]] attributes, but will report an error if a
+    ppx produces a [[@jane.non_erasable.*]] attribute.
+
+    As mentioned above, unlike for attributes, the erasable/non-erasable
+    distinction is not meaningful for extension nodes, as the compiler will
+    always error if it sees an uninterpreted extension node. So, for purposes
+    of tools in the wider OCaml ecosystem, it is irrelevant whether embeddings
+    that use extension nodes indicate [Erasable] or [Non_erasable] for this
+    component, but the semantically correct choice and the one we've settled
+    on is to use [Non_erasable]. *)
+module Erasability = struct
+  type t =
+    | Erasable
+    | Non_erasable
+
+  let to_string = function
+    | Erasable -> "erasable"
+    | Non_erasable -> "non_erasable"
+  ;;
+
+  let of_string = function
+    | "erasable" -> Ok Erasable
+    | "non_erasable" -> Ok Non_erasable
+    | _ -> Error ()
+  ;;
+end
+
+(** An AST-style representation of the names used when generating extension
+    nodes or attributes for modular syntax; see the .mli file for more
+    details. *)
+module Embedded_name : sig
+  (** A nonempty list of name components, without the first two components.
+      (That is, without the leading root component that identifies it as part of
+      the modular syntax mechanism, and without the next component that
+      identifies the erasability.) See the .mli file for more details. *)
+  type components = ( :: ) of string * string list
+
+  type t =
+    { erasability : Erasability.t
+    ; components : components
+    }
+
+  (** See the mli. *)
+  val of_feature : Feature.t -> string list -> t
+
+  val components : t -> components
+
+  (** See the mli. *)
+  val to_string : t -> string
+
+  (** Parse a Jane syntax name from the OCaml AST, either as the name of an
+      extension node or an attribute:
+        - [Some (Ok _)] if it's a legal Jane-syntax name;
+        - [Some (Error _)] if the root is present, but the name has fewer than 3
+          components or the erasability component is malformed; and
+        - [None] if it doesn't start with the leading root name and isn't part
+          of our Jane-syntax machinery.
+      Not exposed. *)
+  val of_string : string -> (t, Misnamed_embedding_error.t) result option
+
+  (** Print out the embedded form of a Jane-syntax name, in quotes; for use in
+      error messages. *)
+  val pp_quoted_name : Format_doc.formatter -> t -> unit
+
+  (** Print out an empty extension node or attribute with a Jane-syntax name,
+      accompanied by an indefinite article; for use in error messages.  Not
+      exposed. *)
+  val pp_a_term : Format_doc.formatter -> Embedding_syntax.t * t -> unit
+end = struct
+  (** The three parameters that control how we encode Jane-syntax extension node
+      names.  When updating these, update comments that refer to them by their
+      contents! *)
+  module Config = struct
+    (** The separator between name components *)
+    let separator = '.'
+
+    (** The leading namespace that identifies this extension node or attribute
+        as reserved for a piece of modular syntax *)
+    let root = "jane"
+
+    (** For printing purposes, the appropriate indefinite article for [root] *)
+    let article = "a"
+  end
+
+  include Config
+
+  let separator_str = String.make 1 separator
+
+  type components = ( :: ) of string * string list
+
+  type t =
+    { erasability : Erasability.t
+    ; components : components
+    }
+
+  let of_feature feature trailing_components =
+    let feature_component = Feature.extension_component feature in
+    let erasability : Erasability.t =
+      if Feature.is_erasable feature then Erasable else Non_erasable
+    in
+    { erasability; components = feature_component :: trailing_components }
+  ;;
+
+  let components t = t.components
+
+  let to_string { erasability; components = feat :: subparts } =
+    String.concat
+      separator_str
+      (root :: Erasability.to_string erasability :: feat :: subparts)
+  ;;
+
+  let of_string str : (t, Misnamed_embedding_error.t) result option =
+    match String.split_on_char separator str with
+    | root' :: parts when String.equal root root' ->
+      (match parts with
+       | [] -> Some (Error No_erasability)
+       | [ _ ] -> Some (Error No_feature)
+       | erasability :: feat :: subparts ->
+         (match Erasability.of_string erasability with
+          | Ok erasability -> Some (Ok { erasability; components = feat :: subparts })
+          | Error () -> Some (Error (Unknown_erasability erasability))))
+    | _ :: _ | [] -> None
+  ;;
+
+  let pp_quoted_name ppf t = Format_doc.fprintf ppf "\"%s\"" (to_string t)
+
+  let pp_a_term ppf (esyn, t) =
+    Format_doc.fprintf ppf "%s %a" article Embedding_syntax.pp (esyn, to_string t)
+  ;;
+end
+
+(******************************************************************************)
+module Error = struct
+  (** An error triggered when desugaring a language extension from an OCaml
+      AST; should always be fatal *)
+  type error =
+    | Introduction_has_payload of Embedding_syntax.t * Embedded_name.t * payload
+    | Unknown_extension of Embedding_syntax.t * Erasability.t * string
+    | Disabled_extension :
+        { ext : _ Language_extension.t
+        ; maturity : Language_extension.maturity option
+        }
+        -> error
+    | Wrong_syntactic_category of Feature.t * string
+    | Misnamed_embedding of Misnamed_embedding_error.t * string * Embedding_syntax.t
+    | Bad_introduction of Embedding_syntax.t * Embedded_name.t
+
+  (** The exception type thrown when desugaring a piece of modular syntax from
+      an OCaml AST *)
+  exception Error of Location.t * error
+end
+
+open Error
+
+let assert_extension_enabled (type a) ~loc (ext : a Language_extension.t) (setting : a) =
+  if not (Language_extension.is_at_least ext setting)
+  then (
+    let maturity : Language_extension.maturity option =
+      match ext with
+      | Layouts -> Some (setting : Language_extension.maturity)
+      | _ -> None
+    in
+    raise (Error (loc, Disabled_extension { ext; maturity })))
+;;
+
+let report_error ~loc = function
+  | Introduction_has_payload (what, name, _payload) ->
+    Location.errorf
+      ~loc
+      "@[Modular syntax %s are not allowed to have a payload,@ but %a does@]"
+      (Embedding_syntax.name_plural what)
+      Embedded_name.pp_quoted_name
+      name
+  | Unknown_extension (what, erasability, name) ->
+    let embedded_name = { Embedded_name.erasability; components = [ name ] } in
+    Location.errorf
+      ~loc
+      "@[Unknown extension \"%s\" referenced via@ %a %s@]"
+      name
+      Embedded_name.pp_a_term
+      (what, embedded_name)
+      (Embedding_syntax.name what)
+  | Disabled_extension { ext; maturity } ->
+    (match maturity with
+     | None ->
+       Location.errorf
+         ~loc
+         "The extension \"%s\" is disabled and cannot be used"
+         (Language_extension.to_string ext)
+     | Some maturity ->
+       Location.errorf
+         ~loc
+         "This construct requires the %s version of the extension \"%s\", which is \
+          disabled and cannot be used"
+         (Language_extension.maturity_to_string maturity)
+         (Language_extension.to_string ext))
+  | Wrong_syntactic_category (feat, cat) ->
+    Location.errorf ~loc "%s cannot appear in %s" (Feature.describe_uppercase feat) cat
+  | Misnamed_embedding (err, name, what) ->
+    Location.errorf
+      ~loc
+      "Cannot have %s named %a: %s"
+      (Embedding_syntax.name_indefinite what)
+      Embedding_syntax.pp
+      (what, name)
+      (Misnamed_embedding_error.to_string err)
+  | Bad_introduction (what, ({ components = ext :: _; _ } as name)) ->
+    Location.errorf
+      ~loc
+      "@[The extension \"%s\" was referenced improperly; it started with@ %a %s,@ not %a \
+       one@]"
+      ext
+      Embedded_name.pp_a_term
+      (what, name)
+      (Embedding_syntax.name what)
+      Embedded_name.pp_a_term
+      (what, { name with components = [ ext ] })
+;;
+
+let () =
+  Location.register_error_of_exn (function
+    | Error (loc, err) -> Some (report_error ~loc err)
+    | _ -> None)
+;;
+
+(******************************************************************************)
+(** Generically find and create the OCaml AST syntax used to encode one of our
+    novel syntactic features.  One module per variety of AST (expressions,
+    patterns, etc.). *)
+
+(** The parameters that define how to look for [[%jane.*.FEATNAME]] and
+    [[@jane.*.FEATNAME]] inside ASTs of a certain syntactic category. This
+    module type describes the input to the [Make_with_attribute] and
+    [Make_with_extension_node] functors (though they stipulate additional
+    requirements for their inputs).
+*)
+module type AST_syntactic_category = sig
+  (** The AST type (e.g., [Parsetree.expression]) *)
+  type ast
+
+  (** The name for this syntactic category in the plural form; used for error
+      messages (e.g., "expressions") *)
+  val plural : string
+
+  (** How to get the location attached to an AST node.  Should just be
+      [fun tm -> tm.pCAT_loc] for the appropriate syntactic category [CAT]. *)
+  val location : ast -> Location.t
+
+  (** Set the location of an AST node. *)
+  val with_location : ast -> Location.t -> ast
+end
+
+module type AST_internal = sig
+  include AST_syntactic_category
+
+  val embedding_syntax : Embedding_syntax.t
+  val make_jane_syntax : Embedded_name.t -> ?payload:payload -> ast -> ast
+
+  (** Given an AST node, check if it's a representation of a term from one of
+      our novel syntactic features; if it is, split it back up into its name,
+      the location of the extension/attribute, any payload, and the body.  If
+      the embedded term is malformed in any way, raises an error; if the input
+      isn't an embedding of one of our novel syntactic features, returns [None].
+      Partial inverse of [make_jane_syntax]. *)
+  val match_jane_syntax
+    :  ast
+    -> (Embedded_name.t * Location.t * Parsetree.payload * ast) option
+end
+
+(* Parses the embedded name from an embedding, raising if
+    the embedding is malformed. Malformed means that
+    NAME is missing; e.g. the attribute is just [[@jane]].
+*)
+let parse_embedding_exn ~loc ~name ~embedding_syntax =
+  let raise_error err = raise (Error (loc, err)) in
+  match Embedded_name.of_string name with
+  | Some (Ok name) -> Some name
+  | Some (Error err) -> raise_error (Misnamed_embedding (err, name, embedding_syntax))
+  | None -> None
+;;
+
+let find_and_remove_jane_syntax_attribute =
+  (* Recurs on [rev_prefix] *)
+  let rec loop ~rev_prefix ~suffix =
+    match rev_prefix with
+    | [] -> None
+    | attr :: rev_prefix ->
+      let { attr_name = { txt = name; loc = attr_loc }; attr_payload } = attr in
+      (match parse_embedding_exn ~loc:attr_loc ~name ~embedding_syntax:Attribute with
+       | None -> loop ~rev_prefix ~suffix:(attr :: suffix)
+       | Some name ->
+         let unconsumed_attributes = List.rev_append rev_prefix suffix in
+         Some (name, attr_loc, attr_payload, unconsumed_attributes))
+  in
+  fun attributes -> loop ~rev_prefix:(List.rev attributes) ~suffix:[]
+;;
+
+let make_jane_syntax_attribute name payload =
+  { attr_name = { txt = Embedded_name.to_string name; loc = !Ast_helper.default_loc }
+  ; attr_loc = !Ast_helper.default_loc
+  ; attr_payload = payload
+  }
+;;
+
+(** For a syntactic category, produce translations into and out of
+    our novel syntax, using parsetree attributes as the encoding.
+*)
+module Make_with_attribute (AST_syntactic_category : sig
+  include AST_syntactic_category
+
+  val attributes : ast -> attributes
+  val with_attributes : ast -> attributes -> ast
+end) : AST_internal with type ast = AST_syntactic_category.ast = struct
+  include AST_syntactic_category
+
+  let embedding_syntax = Embedding_syntax.Attribute
+
+  let make_jane_syntax name ?(payload = PStr []) ast =
+    let attr = make_jane_syntax_attribute name payload in
+    (* See Note [Outer attributes at end] in jane_syntax.ml *)
+    with_attributes ast (attributes ast @ [ attr ])
+  ;;
+
+  let match_jane_syntax ast =
+    match find_and_remove_jane_syntax_attribute (attributes ast) with
+    | None -> None
+    | Some (name, loc, payload, attrs) ->
+      Some (name, loc, payload, with_attributes ast attrs)
+  ;;
+end
+
+(** For a syntactic category, produce translations into and out of
+    our novel syntax, using extension nodes as the encoding.
+*)
+module Make_with_extension_node (AST_syntactic_category : sig
+  include AST_syntactic_category
+
+  (** How to construct an extension node for this AST (something of the
+          shape [[%name]]). Should just be [Ast_helper.CAT.extension] for the
+          appropriate syntactic category [CAT]. (This means that [?loc] should
+          default to [!Ast_helper.default_loc.].) *)
+  val make_extension_node : ?loc:Location.t -> ?attrs:attributes -> extension -> ast
+
+  (** Given an extension node (as created by [make_extension_node]) with an
+          appropriately-formed name and a body, combine them into the special
+          syntactic form we use for novel syntactic features in this syntactic
+          category. Partial inverse of [match_extension_use]. *)
+  val make_extension_use : extension_node:ast -> ast -> ast
+
+  (** Given an AST node, check if it's of the special syntactic form
+          indicating that this is one of our novel syntactic features (as
+          created by [make_extension_node]), split it back up into the extension
+          node and the possible body. Doesn't do any checking about the
+          name/format of the extension or the possible body terms (for which see
+          [AST.match_extension]). Partial inverse of [make_extension_use]. *)
+  val match_extension_use : ast -> (extension * ast) option
+end) : AST_internal with type ast = AST_syntactic_category.ast = struct
+  include AST_syntactic_category
+
+  let embedding_syntax = Embedding_syntax.Extension_node
+
+  let make_jane_syntax name ?(payload = PStr []) ast =
+    make_extension_use
+      ast
+      ~extension_node:
+        (make_extension_node
+           ({ txt = Embedded_name.to_string name; loc = !Ast_helper.default_loc }, payload))
+  ;;
+
+  let match_jane_syntax ast =
+    match match_extension_use ast with
+    | None -> None
+    | Some (({ txt = name; loc = ext_loc }, ext_payload), body) ->
+      (match parse_embedding_exn ~loc:ext_loc ~name ~embedding_syntax with
+       | None -> None
+       | Some name -> Some (name, ext_loc, ext_payload, body))
+  ;;
+end
+
+(********************************************************)
+(* Modules representing individual syntactic categories *)
+
+(* Note [Hiding internal details]
+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+   Each such module is first written with a '0' suffix. These '0'
+   modules are used internally as arguments to [Make_ast] to produce
+   non-'0' modules which are exported. This approach allows us to
+   hide details of these modules necessary for [Make_ast] but
+   unnecessary for external uses.
+*)
+
+(** The AST parameters for every subset of types; embedded with attributes. *)
+module Type_AST_syntactic_category = struct
+  type ast = core_type
+
+  (* Missing [plural] *)
+
+  let location typ = typ.ptyp_loc
+  let with_location typ l = { typ with ptyp_loc = l }
+  let attributes typ = typ.ptyp_attributes
+  let with_attributes typ ptyp_attributes = { typ with ptyp_attributes }
+end
+
+(** Types; embedded with attributes. *)
+module Core_type0 = Make_with_attribute (struct
+  include Type_AST_syntactic_category
+
+  let plural = "types"
+end)
+
+(** Constructor arguments; the same as types, but used in fewer places *)
+module Constructor_argument0 = Make_with_attribute (struct
+  include Type_AST_syntactic_category
+
+  let plural = "constructor arguments"
+end)
+
+(** Expressions; embedded using an attribute on the expression. *)
+module Expression0 = Make_with_attribute (struct
+  type ast = expression
+
+  let plural = "expressions"
+  let location expr = expr.pexp_loc
+  let with_location expr l = { expr with pexp_loc = l }
+  let attributes expr = expr.pexp_attributes
+  let with_attributes expr pexp_attributes = { expr with pexp_attributes }
+end)
+
+(** Patterns; embedded using an attribute on the pattern. *)
+module Pattern0 = Make_with_attribute (struct
+  type ast = pattern
+
+  let plural = "patterns"
+  let location pat = pat.ppat_loc
+  let with_location pat l = { pat with ppat_loc = l }
+  let attributes pat = pat.ppat_attributes
+  let with_attributes pat ppat_attributes = { pat with ppat_attributes }
+end)
+
+(** Module types; embedded using an attribute on the module type. *)
+module Module_type0 = Make_with_attribute (struct
+  type ast = module_type
+
+  let plural = "module types"
+  let location mty = mty.pmty_loc
+  let with_location mty l = { mty with pmty_loc = l }
+  let attributes mty = mty.pmty_attributes
+  let with_attributes mty pmty_attributes = { mty with pmty_attributes }
+end)
+
+(** Extension constructors; embedded using an attribute. *)
+module Extension_constructor0 = Make_with_attribute (struct
+  type ast = extension_constructor
+
+  let plural = "extension constructors"
+  let location ext = ext.pext_loc
+  let with_location ext l = { ext with pext_loc = l }
+  let attributes ext = ext.pext_attributes
+  let with_attributes ext pext_attributes = { ext with pext_attributes }
+end)
+
+(** Signature items; embedded as
+    [include sig [%%extension.EXTNAME];; BODY end]. Signature items don't have
+    attributes or we'd use them instead.
+*)
+module Signature_item0 = Make_with_extension_node (struct
+  type ast = signature_item
+
+  let plural = "signature items"
+  let location sigi = sigi.psig_loc
+  let with_location sigi l = { sigi with psig_loc = l }
+  let make_extension_node = Ast_helper.Sig.extension
+
+  let make_extension_use ~extension_node sigi =
+    Ast_helper.Sig.include_
+      { pincl_mod = Ast_helper.Mty.signature [ extension_node; sigi ]
+      ; pincl_loc = !Ast_helper.default_loc
+      ; pincl_attributes = []
+      }
+  ;;
+
+  let match_extension_use sigi =
+    match sigi.psig_desc with
+    | Psig_include
+        { pincl_mod =
+            { pmty_desc =
+                Pmty_signature [ { psig_desc = Psig_extension (ext, []); _ }; sigi ]
+            ; _
+            }
+        ; _
+        } -> Some (ext, sigi)
+    | _ -> None
+  ;;
+end)
+
+(** Structure items; embedded as
+    [include struct [%%extension.EXTNAME];; BODY end]. Structure items don't
+    have attributes or we'd use them instead.
+*)
+module Structure_item0 = Make_with_extension_node (struct
+  type ast = structure_item
+
+  let plural = "structure items"
+  let location stri = stri.pstr_loc
+  let with_location stri l = { stri with pstr_loc = l }
+  let make_extension_node = Ast_helper.Str.extension
+
+  let make_extension_use ~extension_node stri =
+    Ast_helper.Str.include_
+      { pincl_mod = Ast_helper.Mod.structure [ extension_node; stri ]
+      ; pincl_loc = !Ast_helper.default_loc
+      ; pincl_attributes = []
+      }
+  ;;
+
+  let match_extension_use stri =
+    match stri.pstr_desc with
+    | Pstr_include
+        { pincl_mod =
+            { pmod_desc =
+                Pmod_structure [ { pstr_desc = Pstr_extension (ext, []); _ }; stri ]
+            ; _
+            }
+        ; _
+        } -> Some (ext, stri)
+    | _ -> None
+  ;;
+end)
+
+(** Constructor declarations; embedded with attributes. *)
+module Constructor_declaration0 = Make_with_attribute (struct
+  type ast = Parsetree.constructor_declaration
+
+  let plural = "constructor declarations"
+  let location pcd = pcd.pcd_loc
+  let with_location pcd loc = { pcd with pcd_loc = loc }
+  let attributes pcd = pcd.pcd_attributes
+  let with_attributes pcd pcd_attributes = { pcd with pcd_attributes }
+end)
+
+(** Type declarations; embedded with attributes. *)
+module Type_declaration0 = Make_with_attribute (struct
+  type ast = Parsetree.type_declaration
+
+  let plural = "type declarations"
+  let location ptype = ptype.ptype_loc
+  let with_location ptype loc = { ptype with ptype_loc = loc }
+  let attributes ptype = ptype.ptype_attributes
+  let with_attributes ptype ptype_attributes = { ptype with ptype_attributes }
+end)
+
+(******************************************************************************)
+(* Main exports *)
+
+module type AST = sig
+  type ast
+
+  val make_jane_syntax : Feature.t -> string list -> ?payload:payload -> ast -> ast
+  val make_entire_jane_syntax : loc:Location.t -> Feature.t -> (unit -> ast) -> ast
+  val make_of_ast : of_ast_internal:(Feature.t -> ast -> 'a option) -> ast -> 'a option
+end
+
+(* Most of our features make full use of the Jane Syntax framework, which
+   encodes information in a specific way (e.g., payload left empty on purpose).
+   It is therefore nice to check that these conditions are met. This functions
+   returns [true] if the given feature needs these extra checks. *)
+let needs_extra_checks = function
+  | Feature.Language_extension Mode -> false
+  | _ -> true
+;;
+
+(* See Note [Hiding internal details] *)
+module Make_ast (AST : AST_internal) : AST with type ast = AST.ast = struct
+  include AST
+
+  let make_jane_syntax feature trailing_components ?payload ast =
+    AST.make_jane_syntax
+      (Embedded_name.of_feature feature trailing_components)
+      ?payload
+      ast
+  ;;
+
+  let make_entire_jane_syntax ~loc feature ast =
+    AST.with_location
+      (* We can't call [Location.ghostify] here, as we need
+         [jane_syntax_parsing.ml] to build with the upstream compiler; see
+         Note [Buildable with upstream] in jane_syntax.mli for details. *)
+      (Ast_helper.with_default_loc { loc with loc_ghost = true } (fun () ->
+         make_jane_syntax feature [] (ast ())))
+      loc
+  ;;
+
+  (** Generically lift our custom ASTs for our novel syntax from OCaml ASTs. *)
+  let make_of_ast ~of_ast_internal =
+    let of_ast ast =
+      let loc = AST.location ast in
+      let raise_error loc err = raise (Error (loc, err)) in
+      match AST.match_jane_syntax ast with
+      | Some
+          ( ({ erasability; components = [ name ] } as embedded_name)
+          , syntax_loc
+          , payload
+          , ast ) ->
+        (match Feature.of_component name with
+         | Ok feat ->
+           if needs_extra_checks feat
+           then (
+             match payload with
+             | PStr [] -> ()
+             | _ ->
+               raise_error
+                 syntax_loc
+                 (Introduction_has_payload (AST.embedding_syntax, embedded_name, payload)));
+           (match of_ast_internal feat ast with
+            | Some ext_ast -> Some ext_ast
+            | None ->
+              if needs_extra_checks feat
+              then raise_error loc (Wrong_syntactic_category (feat, AST.plural))
+              else None)
+         | Error err ->
+           raise_error
+             loc
+             (match err with
+              | Disabled_extension ext -> Disabled_extension { ext; maturity = None }
+              | Unknown_extension name ->
+                Unknown_extension (AST.embedding_syntax, erasability, name)))
+      | Some (({ components = _ :: _ :: _; _ } as name), _, _, _) ->
+        raise_error loc (Bad_introduction (AST.embedding_syntax, name))
+      | None -> None
+    in
+    of_ast
+  ;;
+end
+
+let make_jane_syntax_attribute feature trailing_components payload =
+  make_jane_syntax_attribute
+    (Embedded_name.of_feature feature trailing_components)
+    payload
+;;
+
+(* See Note [Hiding internal details] *)
+module Expression = Make_ast (Expression0)
+module Pattern = Make_ast (Pattern0)
+module Module_type = Make_ast (Module_type0)
+module Signature_item = Make_ast (Signature_item0)
+module Structure_item = Make_ast (Structure_item0)
+module Core_type = Make_ast (Core_type0)
+module Constructor_argument = Make_ast (Constructor_argument0)
+module Extension_constructor = Make_ast (Extension_constructor0)
+module Constructor_declaration = Make_ast (Constructor_declaration0)
+module Type_declaration = Make_ast (Type_declaration0)

unikernel/duniverse/ppxlib_jane/src/jane_syntax_parsing.mli

@@ -0,0 +1,254 @@
+(*_ This file is manually imported from the Jane Street version of the
+   OCaml compiler. Don't make changes directly to this file. *)
+[@@@ocaml.warning "-missing-record-field-pattern"]
+
+open! Shadow_compiler_distribution
+
+(** This module handles the logic around the syntax of our extensions to OCaml
+    for Jane Street, keeping the gory details wrapped up behind a clean
+    interface.
+
+    As we've started to work on syntactic extensions to OCaml, three concerns
+    arose about the mechanics of how we wanted to maintain these changes in our
+    fork.
+
+    1. We don't want to extend the AST for our fork, as we really want to make
+       sure things like ppxen are cross-compatible between upstream and our
+       fork.  Thankfully, OCaml already provides places to add extra syntax:
+       extension nodes and annotations!  Thus, we have to come up with a way of
+       representing our new syntactic constructs in terms of these constructs.
+
+    2. We don't want to actually match on extension nodes or attributes whose
+       names are specific strings all over the compiler; that's incredibly
+       messy, and it's easy to miss cases, etc.
+
+    3. We want to keep our different novel syntactic features distinct so that
+       we can add them to upstream independently, work on them separately, and
+       so on.
+
+    We have come up with a design that addresses those concerns by providing
+    both a nice compiler-level interface for working with our syntactic
+    extensions as first-class AST nodes, as well as a uniform scheme for
+    translating this to and from OCaml AST values by using extension nodes or
+    attributes.  One wrinkle is that OCaml has many ASTs, one for each syntactic
+    category (expressions, patterns, etc.); we have to provide this facility for
+    each syntactic category where we want to provide extensions.  A smaller
+    wrinkle is that our novel syntactic features come in two varieties:
+    *language extensions* (e.g., comprehensions) and *built-in features* (e.g.,
+    syntactic function arity).  While the former can be disabled, the latter are
+    parse tree changes we rely on (though they won't therefore show up in
+    surface syntax).
+
+    a. For each novel syntactic feature, we will define a module (e.g.,
+       [Comprehensions]), in which we define a proper AST type per syntactic
+       category we care about (e.g., [Comprehensions.expression] and its
+       subcomponents).  This addresses concern (3); we've now contained each
+       separate feature (and the built-in changes) in a module.  But just doing
+       that would leave them too siloed, so…
+
+    b. We define an *overall auxiliary AST* for each syntactic category that's
+       just for our novel syntactic features; for expressions, it's called
+       [Jane_syntax.Expression.t].  It contains one constructor for each of the
+       AST types defined as described in design point (1).  This addresses
+       concern (2); we can now match on actual OCaml constructors, as long as we
+       can get ahold of them.  And to do that…
+
+    c. We define a general scheme for how we represent our novel syntactic
+       features in terms of the existing ASTs, and provide a few primitives for
+       consuming/creating AST nodes of this form, for each syntactic category.
+       There's not a lot of abstraction to be done, or at least it's not (yet)
+       apparent what abstraction there is to do, so most of this remains manual.
+       (Setting up a full lens-based/otherwise bidirectional approach sounds
+       like a great opportunity for yak-shaving, but not *actually* a good
+       idea.)  This solves concern (3), and by doing it uniformly helps us
+       address multiple cases at one stroke.
+
+    Then, for each syntactic category, we define a module (in
+    [jane_syntax_parsing.ml]) that contains functions for converting between the
+    [Parsetree] representation and the higher-level representation. These
+    modules are inhabitants of [AST.t], and the [AST] module exposes operations
+    on them.
+
+    This module contains the logic for moving to and from OCaml ASTs; the gory
+    details of the encoding are detailed in the implementation.  All the actual
+    ASTs should live in [Jane_syntax], which is the only module that should
+    directly depend on this one.
+
+    When using this module, we often want to specify what our syntax extensions
+    look like when desugared into OCaml ASTs, so that we can validate the
+    translation code.  We generally specify this as a BNF grammar, but we don't
+    want to depend on the specific details of the desugaring.  Thus, instead of
+    writing out extension nodes or attributes directly, we write the result of
+    [Some_ast.make_extension ~loc [name1; name2; ...; NameN] a] as the special
+    syntax [{% 'name1.name2.....nameN' | a %}] in the BNF.  Other pieces of the
+    OCaml AST are used as normal.
+
+    One detail which we hide as much as possible is locations: whenever
+    constructing an OCaml AST node -- whether with [wrap_desc], the functions in
+    [Ast_helper], or some other way -- the location should be left to be
+    defaulted (and the default, [!Ast_helper.make_default], should be ghost).
+    The [make_entire_jane_syntax] function will handle making sure this default
+    location is set appropriately.  If this isn't done and any locations on
+    subterms aren't marked as ghost, the compiler will work fine, but ppxlib may
+    detect that you've violated its well-formedness constraints and fail to
+    parse the resulting AST. *)
+
+(******************************************************************************)
+
+(** The type enumerating our novel syntactic features, which are either a
+    language extension (separated out by which one) or the collection of all
+    built-in features. *)
+module Feature : sig
+  type t =
+    | Language_extension : _ Language_extension.t -> t
+    | Builtin
+
+  (** The component of an attribute or extension name that identifies the
+      feature. This is third component.
+  *)
+  val extension_component : t -> string
+end
+
+(** An AST-style representation of the names used when generating extension
+    nodes or attributes for modular syntax.  We use this to abstract over the
+    details of how they're encoded, so we have some flexibility in changing them
+    (although comments may refer to the specific encoding choices).  This is
+    also why we don't expose any functions for rendering or parsing these names;
+    that's all handled internally. *)
+module Embedded_name : sig
+  (** A nonempty list of name components, without the first two components.
+      (That is, without the leading root component that identifies it as part of
+      the modular syntax mechanism, and without the next component that
+      identifies the erasability.)
+
+      This is a nonempty list corresponding to the different components of the
+      name: first the feature, and then any subparts.
+  *)
+  type components = ( :: ) of string * string list
+
+  type t
+
+  (** Creates an embedded name whose erasability component is whether the
+      feature is erasable, and whose feature component is the feature's name.
+      The second argument is treated as the trailing components after the
+      feature name.
+  *)
+  val of_feature : Feature.t -> string list -> t
+
+  val components : t -> components
+
+  (** Convert one of these Jane syntax names to the embedded string form used in
+      the OCaml AST as the name of an extension node or an attribute; exposed
+      for extensions that only uses [Embedded_name] instead of the whole
+      infrastructure in this module, such as the dummy argument extension *)
+  val to_string : t -> string
+
+  (** Print out the embedded form of a Jane-syntax name, in quotes; for use in
+      error messages. *)
+  val pp_quoted_name : Format_doc.formatter -> t -> unit
+end
+
+(** Each syntactic category that contains novel syntactic features has a
+    corresponding module of this module type.  We're adding these lazily as we
+    need them. When you add another one, make sure also to add special handling
+    in [Ast_iterator] and [Ast_mapper].
+*)
+module type AST = sig
+  (** The AST type (e.g., [Parsetree.expression]) *)
+  type ast
+
+  (** Embed a term from one of our novel syntactic features in the AST using the
+      given name (in the [Feature.t]) and body (the [ast]).  Any locations in
+      the generated AST will be set to [!Ast_helper.default_loc], which should
+      be [ghost]. *)
+  val make_jane_syntax
+    :  Feature.t
+    -> string list
+    -> ?payload:Parsetree.payload
+    -> ast
+    -> ast
+
+  (** As [make_jane_syntax], but specifically for the AST node corresponding to
+      the entire piece of novel syntax (e.g., for a list comprehension, the
+      whole [[x for x in xs]], and not a subcomponent like [for x in xs]).  This
+      sets [Ast_helper.default_loc] locally to the [ghost] version of the
+      provided location, which is why the [ast] is generated from a function
+      call; it is during this call that the location is so set. *)
+  val make_entire_jane_syntax : loc:Location.t -> Feature.t -> (unit -> ast) -> ast
+
+  (** Build an [of_ast] function. The return value of this function should be
+      used to implement [of_ast] in modules satisfying the signature
+      [Jane_syntax.AST].
+
+      The returned function interprets an AST term in the specified syntactic
+      category as a term of the appropriate auxiliary extended AST if possible.
+      It raises an error if it finds a term from a disabled extension or if the
+      embedding is malformed.
+  *)
+  val make_of_ast
+    :  of_ast_internal:(Feature.t -> ast -> 'a option)
+         (** A function to convert [Parsetree]'s AST to our novel extended one.  The
+        choice of feature and the piece of syntax will both be extracted from
+        the embedding by the first argument.
+
+        If the given syntax feature does not actually extend the given syntactic
+        category, returns [None]; this will be reported as an error. (For
+        example: There are no pattern comprehensions, so when building the
+        extended pattern AST, this function will return [None] if it spots an
+        embedding that claims to be from [Language_extension Comprehensions].)
+    *)
+    -> ast
+    -> 'a option
+end
+
+module Expression : AST with type ast = Parsetree.expression
+module Pattern : AST with type ast = Parsetree.pattern
+module Module_type : AST with type ast = Parsetree.module_type
+module Signature_item : AST with type ast = Parsetree.signature_item
+module Structure_item : AST with type ast = Parsetree.structure_item
+module Core_type : AST with type ast = Parsetree.core_type
+module Constructor_argument : AST with type ast = Parsetree.core_type
+module Extension_constructor : AST with type ast = Parsetree.extension_constructor
+module Constructor_declaration : AST with type ast = Parsetree.constructor_declaration
+module Type_declaration : AST with type ast = Parsetree.type_declaration
+
+(** Require that an extension is enabled for at least the provided level, or
+    else throw an exception (of an abstract type) at the provided location
+    saying otherwise.  This is intended to be used in [jane_syntax.ml] when a
+    certain piece of syntax requires two extensions to be enabled at once (e.g.,
+    immutable array comprehensions such as [[:x for x = 1 to 10:]], which
+    require both [Comprehensions] and [Immutable_arrays]). *)
+val assert_extension_enabled : loc:Location.t -> 'a Language_extension.t -> 'a -> unit
+
+(** Extracts the last attribute (in list order) that was inserted by the
+    Jane Syntax framework, and returns the rest of the attributes in the
+    same relative order as was input, along with the location of the removed
+    attribute and its payload.
+
+    This can be used by [Jane_syntax] to peel off individual attributes in
+    order to process a Jane Syntax element that consists of multiple
+    nested ASTs.
+*)
+val find_and_remove_jane_syntax_attribute
+  :  Parsetree.attributes
+  -> (Embedded_name.t * Location.t * Parsetree.payload * Parsetree.attributes) option
+
+(** Creates an attribute used for encoding syntax from the given [Feature.t] *)
+val make_jane_syntax_attribute
+  :  Feature.t
+  -> string list
+  -> Parsetree.payload
+  -> Parsetree.attribute
+
+(** Errors around the representation of our extended ASTs.  These should mostly
+    just be fatal, but they're needed for one test case
+    (language-extensions/language_extensions.ml). *)
+module Error : sig
+  (** An error triggered when desugaring a piece of embedded novel syntax from
+      an OCaml AST; left abstract because it should always be fatal *)
+  type error
+
+  (** The exception type thrown when desugaring a piece of extended syntax from
+      an OCaml AST *)
+  exception Error of Location.t * error
+end

unikernel/duniverse/ppxlib_jane/src/language_extension.ml

@@ -0,0 +1,4 @@
+include Language_extension_kernel
+
+let is_enabled _ = true
+let is_at_least _ _ = true

unikernel/duniverse/ppxlib_jane/src/language_extension.mli

@@ -0,0 +1,7 @@
+(** A [ppxlib_jane]-specific copy of the Jane Street-internal language
+    extensions framework that reports that every language extension
+    is enabled. This is the most permissive behavior possible, which
+    is what we want for ppxes that process pieces of Jane Syntax.
+*)
+
+include Language_extension_kernel.Language_extension_for_jane_syntax (** @inline *)

unikernel/duniverse/ppxlib_jane/src/language_extension_kernel.ml

@@ -0,0 +1,119 @@
+(*_ This file is manually imported from the Jane Street version of the
+   OCaml compiler. Don't make changes directly to this file. *)
+[@@@ocaml.warning "-missing-record-field-pattern"]
+
+open! Shadow_compiler_distribution
+
+type maturity =
+  | Stable
+  | Beta
+  | Alpha
+
+(* Remember to update [all] when changing this type. *)
+type _ t =
+  | Comprehensions : unit t
+  | Mode : unit t
+  | Unique : unit t
+  | Include_functor : unit t
+  | Polymorphic_parameters : unit t
+  | Immutable_arrays : unit t
+  | Module_strengthening : unit t
+  | Layouts : maturity t
+  | SIMD : unit t
+  | Labeled_tuples : unit t
+  | Small_numbers : unit t
+
+type 'a language_extension_kernel = 'a t
+
+module Exist = struct
+  type t = Pack : _ language_extension_kernel -> t
+
+  let all =
+    [ Pack Comprehensions
+    ; Pack Mode
+    ; Pack Unique
+    ; Pack Include_functor
+    ; Pack Polymorphic_parameters
+    ; Pack Immutable_arrays
+    ; Pack Module_strengthening
+    ; Pack Layouts
+    ; Pack SIMD
+    ; Pack Labeled_tuples
+    ; Pack Small_numbers
+    ]
+  ;;
+end
+
+module Exist_pair = struct
+  type t = Pair : 'a language_extension_kernel * 'a -> t
+end
+
+(* When you update this, update [pair_of_string] below too. *)
+let to_string : type a. a t -> string = function
+  | Comprehensions -> "comprehensions"
+  | Mode -> "mode"
+  | Unique -> "unique"
+  | Include_functor -> "include_functor"
+  | Polymorphic_parameters -> "polymorphic_parameters"
+  | Immutable_arrays -> "immutable_arrays"
+  | Module_strengthening -> "module_strengthening"
+  | Layouts -> "layouts"
+  | SIMD -> "simd"
+  | Labeled_tuples -> "labeled_tuples"
+  | Small_numbers -> "small_numbers"
+;;
+
+(* converts full extension names, like "layouts_alpha" to a pair of
+   an extension and its maturity. For extensions that don't take an
+   argument, the conversion is just [Language_extension_kernel.of_string].
+*)
+let pair_of_string extn_name : Exist_pair.t option =
+  match String.lowercase_ascii extn_name with
+  | "comprehensions" -> Some (Pair (Comprehensions, ()))
+  | "mode" -> Some (Pair (Mode, ()))
+  | "unique" -> Some (Pair (Unique, ()))
+  | "include_functor" -> Some (Pair (Include_functor, ()))
+  | "polymorphic_parameters" -> Some (Pair (Polymorphic_parameters, ()))
+  | "immutable_arrays" -> Some (Pair (Immutable_arrays, ()))
+  | "module_strengthening" -> Some (Pair (Module_strengthening, ()))
+  | "layouts" -> Some (Pair (Layouts, Stable))
+  | "layouts_alpha" -> Some (Pair (Layouts, Alpha))
+  | "layouts_beta" -> Some (Pair (Layouts, Beta))
+  | "simd" -> Some (Pair (SIMD, ()))
+  | "labeled_tuples" -> Some (Pair (Labeled_tuples, ()))
+  | "small_numbers" -> Some (Pair (Small_numbers, ()))
+  | _ -> None
+;;
+
+let maturity_to_string = function
+  | Alpha -> "alpha"
+  | Beta -> "beta"
+  | Stable -> "stable"
+;;
+
+let of_string extn_name : Exist.t option =
+  match pair_of_string extn_name with
+  | Some (Pair (ext, _)) -> Some (Pack ext)
+  | None -> None
+;;
+
+(* We'll do this in a more principled way later. *)
+let is_erasable : type a. a t -> bool = function
+  | Mode | Unique | Layouts -> true
+  | Comprehensions
+  | Include_functor
+  | Polymorphic_parameters
+  | Immutable_arrays
+  | Module_strengthening
+  | SIMD
+  | Labeled_tuples
+  | Small_numbers -> false
+;;
+
+(* See the mli. *)
+module type Language_extension_for_jane_syntax = sig
+  type nonrec 'a t = 'a t
+
+  val is_enabled : _ t -> bool
+  val is_at_least : 'a t -> 'a -> bool
+end

unikernel/duniverse/ppxlib_jane/src/language_extension_kernel.mli

@@ -0,0 +1,78 @@
+(*_ This file is manually imported from the Jane Street version of the
+   OCaml compiler. Don't make changes directly to this file. *)
+[@@@ocaml.warning "-missing-record-field-pattern"]
+
+open! Shadow_compiler_distribution
+
+(** Language extensions provided by the Jane Street version of the OCaml
+    compiler.
+
+    This is the signature of the {!Language_extension_kernel} module that is
+    directly imported into [ppxlib_jane].
+*)
+
+type maturity =
+  | Stable
+  | Beta
+  | Alpha
+
+(** The type of language extensions. An ['a t] is an extension that can either
+    be off or be set to have any value in ['a], so a [unit t] can be either on
+    or off, while a [maturity t] can have different maturity settings. *)
+type _ t =
+  | Comprehensions : unit t
+  | Mode : unit t
+  | Unique : unit t
+  | Include_functor : unit t
+  | Polymorphic_parameters : unit t
+  | Immutable_arrays : unit t
+  | Module_strengthening : unit t
+  | Layouts : maturity t
+  | SIMD : unit t
+  | Labeled_tuples : unit t
+  | Small_numbers : unit t
+
+module Exist : sig
+  type 'a extn = 'a t
+  type t = Pack : _ extn -> t
+
+  val all : t list
+end
+with type 'a extn := 'a t
+
+module Exist_pair : sig
+  type 'a extn = 'a t
+  type t = Pair : 'a extn * 'a -> t
+end
+with type 'a extn := 'a t
+
+(** Print and parse language extensions; parsing is case-insensitive *)
+val to_string : _ t -> string
+
+val of_string : string -> Exist.t option
+val pair_of_string : string -> Exist_pair.t option
+val maturity_to_string : maturity -> string
+
+(** Check if a language extension is "erasable", i.e. whether it can be
+    harmlessly translated to attributes and compiled with the upstream
+    compiler. *)
+val is_erasable : _ t -> bool
+
+module type Language_extension_for_jane_syntax = sig
+  (** This module type defines the pieces of functionality used by
+      {!Jane_syntax_parsing} and {!Jane_syntax} so that we can more easily
+      import these modules into [ppxlib_jane], without also including all of the
+      [Language_extension] machinery.
+
+      It includes the stateful operations that {!Jane_syntax_parsing} relies on.
+      This limits the number of bindings that [ppxlib_jane] needs to have mock
+      implementations for.
+  *)
+
+  type nonrec 'a t = 'a t
+
+  (** Check if a language extension is currently enabled. *)
+  val is_enabled : _ t -> bool
+
+  val is_at_least : 'a t -> 'a -> bool
+end

unikernel/duniverse/ppxlib_jane/src/ppxlib_jane.ml

@@ -0,0 +1,7 @@
+module Ast_builder = Ast_builder
+module Jane_syntax = Jane_syntax
+
+module For_testing = struct
+  module Language_extension = Language_extension
+  module Language_extension_kernel = Language_extension_kernel
+end

unikernel/duniverse/ppxlib_jane/src/shadow_compiler_distribution.ml

@@ -0,0 +1,56 @@
+(* This should be opened at the start of every file in Jane_syntax.
+
+   These module definitions shadow the compiler's AST with ppxlib's AST. We use this
+   module to manage interface differences between the two AST versions. It allows us to
+   import Jane_syntax from our extended compiler with minimal changes. If we instead used
+   [open Ppxlib_ast], we'd have to update more callsites. *)
+
+module Parsetree = Ppxlib_ast.Parsetree
+module Asttypes = Ppxlib_ast.Asttypes
+module Pprintast = Ppxlib_ast.Pprintast
+
+module Ast_helper = struct
+  include Ppxlib_ast.Ast_helper
+
+  module Te = struct
+    include Te
+
+    let decl ~loc ~vars ~args ?info:_ ?docs:_ ?res name = decl ~loc ~vars ~args ?res name
+  end
+
+  module Type = struct
+    include Type
+
+    let mk ~loc ~docs:_ ?text:_ ~params ~cstrs ~kind ~priv ?manifest name =
+      mk ~loc ~params ~cstrs ~kind ~priv ?manifest name
+    ;;
+
+    let constructor ~loc ~vars ~info:_ ~args ?res name =
+      constructor ~loc ~vars ~args ?res name
+    ;;
+  end
+end
+
+module Printast = struct
+  (* copied and simplified from [Pprintast]. This printing is
+     just used in a rarely-exercised (never-exercised?) error message
+     so can be ad-hoc.
+  *)
+  let payload _ fmt (x : Parsetree.payload) =
+    Format_doc.deprecated_printer (fun fmt ->
+      match (x : Parsetree.payload) with
+      | PStr x -> Pprintast.structure fmt x
+      | PTyp x -> Pprintast.core_type fmt x
+      | PSig x -> Pprintast.signature fmt x
+      | PPat (x, None) -> Pprintast.pattern fmt x
+      | PPat (x, Some e) ->
+        Pprintast.pattern fmt x;
+        Format.pp_print_string fmt " when ";
+        Pprintast.expression fmt e)
+      fmt
+  ;;
+
+  let expression _ fmt x =
+    Format_doc.deprecated_printer
+      (fun fmt -> Astlib.Pprintast.expression fmt x) fmt
+end