pax_global_header00006660000000000000000000000064147154706010014517gustar00rootroot0000000000000052 comment=d9d7271b82d6b5aabab839a4dd2b1e15ef0d96b4 ppxlib_jane-0.17.2/000077500000000000000000000000001471547060100141015ustar00rootroot00000000000000ppxlib_jane-0.17.2/.gitignore000066400000000000000000000000411471547060100160640ustar00rootroot00000000000000_build *.install *.merlin _opam ppxlib_jane-0.17.2/.ocamlformat000066400000000000000000000000231471547060100164010ustar00rootroot00000000000000profile=janestreet ppxlib_jane-0.17.2/CONTRIBUTING.md000066400000000000000000000044101471547060100163310ustar00rootroot00000000000000This 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 ``` 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/ ppxlib_jane-0.17.2/LICENSE.md000066400000000000000000000021461471547060100155100ustar00rootroot00000000000000The MIT License Copyright (c) 2023--2024 Jane Street Group, LLC 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. ppxlib_jane-0.17.2/Makefile000066400000000000000000000004031471547060100155360ustar00rootroot00000000000000INSTALL_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 ppxlib_jane-0.17.2/README.md000066400000000000000000000036451471547060100153700ustar00rootroot00000000000000'`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 ppxlib_jane-0.17.2/dune000066400000000000000000000000001471547060100147450ustar00rootroot00000000000000ppxlib_jane-0.17.2/dune-project000066400000000000000000000000211471547060100164140ustar00rootroot00000000000000(lang dune 3.11) ppxlib_jane-0.17.2/ppxlib_jane.opam000066400000000000000000000013011471547060100172450ustar00rootroot00000000000000opam-version: "2.0" version: "v0.17.2" 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.28.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. " ppxlib_jane-0.17.2/src/000077500000000000000000000000001471547060100146705ustar00rootroot00000000000000ppxlib_jane-0.17.2/src/ast_builder.ml000066400000000000000000000210461471547060100175220ustar00rootroot00000000000000open 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)) ;; ppxlib_jane-0.17.2/src/ast_builder.mli000066400000000000000000000000641471547060100176700ustar00rootroot00000000000000include Ast_builder_intf.Ast_builder (** @inline *) ppxlib_jane-0.17.2/src/ast_builder_intf.ml000066400000000000000000000256731471547060100205540ustar00rootroot00000000000000open 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 ]. 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 -> ], then [e' = fun -> 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 -> ]. 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 -> ], then [add_params params e] is [fun -> ]. *) 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 ppxlib_jane-0.17.2/src/dune000066400000000000000000000002231471547060100155430ustar00rootroot00000000000000(library (name ppxlib_jane) (public_name ppxlib_jane) (libraries compiler-libs.common ppxlib.ast ppxlib.stdppx) (preprocess no_preprocessing)) ppxlib_jane-0.17.2/src/import_jane_syntax_files.sh000077500000000000000000000031711471547060100223300ustar00rootroot00000000000000#!/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" ppxlib_jane-0.17.2/src/imported-commit.txt000066400000000000000000000001361471547060100205420ustar00rootroot00000000000000https://github.com/ocaml-flambda/flambda-backend.git 6dd3ac776ba45ba8193d3a78449952404bdb17de ppxlib_jane-0.17.2/src/jane_asttypes.ml000066400000000000000000000025121471547060100200730ustar00rootroot00000000000000(*_ 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 ppxlib_jane-0.17.2/src/jane_asttypes.mli000066400000000000000000000037051471547060100202510ustar00rootroot00000000000000(*_ 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 ppxlib_jane-0.17.2/src/jane_syntax.ml000066400000000000000000002177261471547060100175640ustar00rootroot00000000000000(*_ 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 open Asttypes open Jane_asttypes open Parsetree open Jane_syntax_parsing (** 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 (* Suppress the unused module warning so it's easy to keep around the shadowing even if we delete use sites of the module. *) module _ = Language_extension (****************************************) (* Helpers used just within this module *) module type Extension = sig val feature : Feature.t end module Ast_of (AST : AST) (Ext : Extension) : sig (* Wrap a bit of AST with a jane-syntax annotation *) val wrap_jane_syntax : string list -> (* these strings describe the bit of new syntax *) ?payload:payload -> AST.ast -> AST.ast end = struct let wrap_jane_syntax suffixes ?payload to_be_wrapped = AST.make_jane_syntax Ext.feature suffixes ?payload to_be_wrapped ;; end module Of_ast (Ext : Extension) : sig module Desugaring_error : sig type error = | Not_this_embedding of Embedded_name.t | Non_embedding end type unwrapped := string list * payload * attributes (* Find and remove a jane-syntax attribute marker, returning an error if the attribute name does not have the right format or extension. *) val unwrap_jane_syntax_attributes : attributes -> (unwrapped, Desugaring_error.error) result (* The same as [unwrap_jane_syntax_attributes], except throwing an exception instead of returning an error. *) val unwrap_jane_syntax_attributes_exn : loc:Location.t -> attributes -> unwrapped end = struct let extension_string = Feature.extension_component Ext.feature module Desugaring_error = struct type error = | Not_this_embedding of Embedded_name.t | Non_embedding let report_error ~loc = function | Not_this_embedding name -> Location.errorf ~loc "Tried to desugar the embedded term %a@ as belonging to the %s extension" Embedded_name.pp_quoted_name name extension_string | Non_embedding -> Location.errorf ~loc "Tried to desugar a non-embedded expression@ as belonging to the %s extension" extension_string ;; exception Error of Location.t * error let () = Location.register_error_of_exn (function | Error (loc, err) -> Some (report_error ~loc err) | _ -> None) ;; let raise ~loc err = raise (Error (loc, err)) end let unwrap_jane_syntax_attributes attrs : (_, Desugaring_error.error) result = match find_and_remove_jane_syntax_attribute attrs with | Some (ext_name, _loc, payload, attrs) -> (match Jane_syntax_parsing.Embedded_name.components ext_name with | extension_occur :: names when String.equal extension_occur extension_string -> Ok (names, payload, attrs) | _ -> Error (Not_this_embedding ext_name)) | None -> Error Non_embedding ;; let unwrap_jane_syntax_attributes_exn ~loc attrs = match unwrap_jane_syntax_attributes attrs with | Ok x -> x | Error error -> Desugaring_error.raise ~loc error ;; end (******************************************************************************) (** Individual language extension modules *) (* Note [Check for immutable extension in comprehensions code] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we spot a comprehension for an immutable array, we need to make sure that both [comprehensions] and [immutable_arrays] are enabled. But our general mechanism for checking for enabled extensions (in [of_ast]) won't work well here: it triggers when converting from e.g. [[%jane.non_erasable.comprehensions.array] ...] to the comprehensions-specific AST. But if we spot a [[%jane.non_erasable.comprehensions.immutable]], there is no expression to translate. So we just check for the immutable arrays extension when processing a comprehension expression for an immutable array. Note [Wrapping with make_entire_jane_syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The topmost node in the encoded AST must always look like e.g. [%jane.non_erasable.comprehensions]. (More generally, [%jane.ERASABILITY.FEATURE] or [@jane.ERASABILITY.FEATURE].) This allows the decoding machinery to know what extension is being used and what function to call to do the decoding. Accordingly, during encoding, after doing the hard work of converting the extension syntax tree into e.g. Parsetree.expression, we need to make a final step of wrapping the result in a [%jane.*.xyz] node. Ideally, this step would be done by part of our general structure, like we separate [of_ast] and [of_ast_internal] in the decode structure; this design would make it structurally impossible/hard to forget taking this final step. However, the final step is only one line of code (a call to [make_entire_jane_syntax]), but yet the name of the feature varies, as does the type of the payload. It would thus take several lines of code to execute this command otherwise, along with dozens of lines to create the structure in the first place. And so instead we just manually call [make_entire_jane_syntax] and refer to this Note as a reminder to authors of future syntax features to remember to do this wrapping. Note [Outer attributes at end] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The order of attributes matters for several reasons: - If the user writes attributes on a Jane Street OCaml construct, where should those appear with respect to the Jane Syntax attribute that introduces the construct? - Some Jane Syntax embeddings use attributes, and sometimes an AST node will have multiple Jane Syntax-related attributes on it. Which attribute should Jane Syntax interpret first? Both of these questions are settled by a convention where attributes appearing later in an attribute list are considered to be "outer" to attributes appearing earlier. (ppxlib adopted this convention, and thus we need to as well for compatibility.) - User-written attributes appear later in the attribute list than a Jane Syntax attribute that introduces a syntactic construct. - If multiple Jane Syntax attributes appear on an AST node, the ones appearing later in the attribute list should be interpreted first. *) module type Payload_protocol = sig type t module Encode : sig val as_payload : t loc -> payload val list_as_payload : t loc list -> payload val option_list_as_payload : t loc option list -> payload end module Decode : sig val from_payload : loc:Location.t -> payload -> t loc val list_from_payload : loc:Location.t -> payload -> t loc list val option_list_from_payload : loc:Location.t -> payload -> t loc option list end end module type Stringable = sig type t val of_string : string -> t option val to_string : t -> string (** For error messages: a name that can be used to identify the [t] being converted to and from string, and its indefinite article (either "a" or "an"). *) val indefinite_article_and_name : string * string end module Make_payload_protocol_of_stringable (Stringable : Stringable) : Payload_protocol with type t := Stringable.t = struct module Encode = struct let as_expr t_loc = let string = Stringable.to_string t_loc.txt in Ast_helper.Exp.ident (Location.mkloc (Longident.Lident string) t_loc.loc) ;; let structure_item_of_expr expr = { pstr_desc = Pstr_eval (expr, []); pstr_loc = Location.none } ;; let structure_item_of_none = { pstr_desc = Pstr_attribute { attr_name = Location.mknoloc "jane.none" ; attr_payload = PStr [] ; attr_loc = Location.none } ; pstr_loc = Location.none } ;; let as_payload t_loc = let expr = as_expr t_loc in PStr [ structure_item_of_expr expr ] ;; let list_as_payload t_locs = let items = List.map (fun t_loc -> structure_item_of_expr (as_expr t_loc)) t_locs in PStr items ;; let option_list_as_payload t_locs = let items = List.map (function | None -> structure_item_of_none | Some t_loc -> structure_item_of_expr (as_expr t_loc)) t_locs in PStr items ;; end module Desugaring_error = struct type error = Unknown_payload of payload let report_error ~loc = function | Unknown_payload payload -> let indefinite_article, name = Stringable.indefinite_article_and_name in Location.errorf ~loc "Attribute payload does not name %s %s:@;%a" indefinite_article name (Printast.payload 0) payload ;; exception Error of Location.t * error let () = Location.register_error_of_exn (function | Error (loc, err) -> Some (report_error ~loc err) | _ -> None) ;; let raise ~loc err = raise (Error (loc, err)) end module Decode = struct (* Avoid exporting a definition that raises [Unexpected]. *) open struct exception Unexpected let from_expr = function | { pexp_desc = Pexp_ident payload_lid; _ } -> let t = match Stringable.of_string (Longident.last payload_lid.txt) with | None -> raise Unexpected | Some t -> t in Location.mkloc t payload_lid.loc | _ -> raise Unexpected ;; let expr_of_structure_item = function | { pstr_desc = Pstr_eval (expr, _) } -> expr | _ -> raise Unexpected ;; let is_none_structure_item = function | { pstr_desc = Pstr_attribute { attr_name = { txt = "jane.none" } } } -> true | _ -> false ;; let from_payload payload = match payload with | PStr [ item ] -> from_expr (expr_of_structure_item item) | _ -> raise Unexpected ;; let list_from_payload payload = match payload with | PStr items -> List.map (fun item -> from_expr (expr_of_structure_item item)) items | _ -> raise Unexpected ;; let option_list_from_payload payload = match payload with | PStr items -> List.map (fun item -> if is_none_structure_item item then None else Some (from_expr (expr_of_structure_item item))) items | _ -> raise Unexpected ;; end let from_payload ~loc payload : _ loc = try from_payload payload with | Unexpected -> Desugaring_error.raise ~loc (Unknown_payload payload) ;; let list_from_payload ~loc payload : _ list = try list_from_payload payload with | Unexpected -> Desugaring_error.raise ~loc (Unknown_payload payload) ;; let option_list_from_payload ~loc payload : _ list = try option_list_from_payload payload with | Unexpected -> Desugaring_error.raise ~loc (Unknown_payload payload) ;; end end module Stringable_const_jkind = struct type t = const_jkind let indefinite_article_and_name = "a", "layout" let to_string = jkind_to_string let of_string t = Some (jkind_of_string t) end module Jkinds_pprint = struct let const_jkind fmt cl = Format_doc.fprintf fmt "%s" (Stringable_const_jkind.to_string cl) ;; let jkind_annotation fmt ann = const_jkind fmt ann.txt end (** Jkind annotations' encoding as attribute payload, used in both n-ary functions and jkinds. *) module Jkind_annotation : sig include Payload_protocol with type t := const_jkind module Decode : sig include module type of Decode val bound_vars_from_vars_and_payload : loc:Location.t -> string Location.loc list -> payload -> (string Location.loc * jkind_annotation option) list end end = struct module Protocol = Make_payload_protocol_of_stringable (Stringable_const_jkind) (*******************************************************) (* Conversions with a payload *) module Encode = Protocol.Encode module Decode = struct include Protocol.Decode module Desugaring_error = struct type error = Wrong_number_of_jkinds of int * jkind_annotation option list let report_error ~loc = function | Wrong_number_of_jkinds (n, jkinds) -> Location.errorf ~loc "Wrong number of layouts in an layout attribute;@;\ expecting %i but got this list:@;\ %a" n (Format_doc.pp_print_list (Format_doc.pp_print_option ~none:(fun ppf () -> Format_doc.fprintf ppf "None") Jkinds_pprint.jkind_annotation)) jkinds ;; exception Error of Location.t * error let () = Location.register_error_of_exn (function | Error (loc, err) -> Some (report_error ~loc err) | _ -> None) ;; let raise ~loc err = raise (Error (loc, err)) end let bound_vars_from_vars_and_payload ~loc var_names payload = let jkinds = option_list_from_payload ~loc payload in try List.combine var_names jkinds with (* seems silly to check the length in advance when [combine] does *) | Invalid_argument _ -> Desugaring_error.raise ~loc (Wrong_number_of_jkinds (List.length var_names, jkinds)) ;; end end module Mode_expr = struct module Const : sig type raw = string type t = private raw Location.loc val mk : string -> Location.t -> t val list_as_payload : t list -> payload val list_from_payload : loc:Location.t -> payload -> t list val ghostify : t -> t end = struct type raw = string module Protocol = Make_payload_protocol_of_stringable (struct type t = raw let indefinite_article_and_name = "a", "mode" let to_string s = s (* Ideally, we should check that [s] consists of only alphabet and numbers. However, this func *) let of_string' s = s let of_string s = Some (of_string' s) end) let list_as_payload = Protocol.Encode.list_as_payload let list_from_payload = Protocol.Decode.list_from_payload type t = raw Location.loc let mk txt loc : t = { txt; loc } let ghostify { txt; loc } = let loc = { loc with loc_ghost = true } in { txt; loc } ;; end type t = Const.t list Location.loc let empty = Location.mknoloc [] let singleton const = let const' = (const : Const.t :> _ Location.loc) in Location.mkloc [ const ] const'.loc ;; let feature : Feature.t = Language_extension Mode let attribute_components = [] let extension_components = [] let attribute_name = Embedded_name.of_feature feature attribute_components |> Embedded_name.to_string ;; let extension_name = Embedded_name.of_feature feature extension_components |> Embedded_name.to_string ;; let payload_of { txt; _ } = match txt with | [] -> None | _ :: _ as txt -> Some (Const.list_as_payload txt) ;; let of_payload ~loc payload = let l = Const.list_from_payload ~loc payload in match l with | [] -> Misc.fatal_error "Payload encoding empty mode expression" | _ :: _ -> Location.mkloc l loc ;; let extract_attr attrs = let attrs, rest = List.partition (fun { attr_name; _ } -> attr_name.txt = attribute_name) attrs in match attrs with | [] -> None, rest | [ attr ] -> Some attr, rest | _ :: _ :: _ -> Misc.fatal_error "More than one mode attribute" ;; let of_attr { attr_payload; attr_loc; _ } = of_payload ~loc:attr_loc attr_payload let maybe_of_attrs attrs = let attr, rest = extract_attr attrs in let mode = Option.map of_attr attr in mode, rest ;; let of_attrs attrs = let mode, rest = maybe_of_attrs attrs in let mode = Option.value mode ~default:empty in mode, rest ;; let attr_of modes = match payload_of modes with | None -> None | Some attr_payload -> let attr_name = Location.mknoloc attribute_name in let attr_loc = modes.loc in Some { attr_name; attr_loc; attr_payload } ;; let ghostify { txt; loc } = let loc = { loc with loc_ghost = true } in let txt = List.map Const.ghostify txt in { loc; txt } ;; end (** List and array comprehensions *) module Comprehensions = struct module Ext = struct let feature : Feature.t = Language_extension Comprehensions end module Ast_of = Ast_of (Expression) (Ext) module Of_ast = Of_ast (Ext) include Ext type iterator = | Range of { start : expression ; stop : expression ; direction : direction_flag } | In of expression type clause_binding = { pattern : pattern ; iterator : iterator ; attributes : attribute list } type clause = | For of clause_binding list | When of expression type comprehension = { body : expression ; clauses : clause list } type expression = | Cexp_list_comprehension of comprehension | Cexp_array_comprehension of mutable_flag * comprehension (* The desugared-to-OCaml version of comprehensions is described by the following BNF, where [{% '...' | expr %}] refers to the result of [Expression.make_jane_syntax] (via [comprehension_expr]) as described at the top of [jane_syntax_parsing.mli]. {v comprehension ::= | {% 'comprehension.list' | '[' clauses ']' %} | {% 'comprehension.array' | '[|' clauses '|]' %} clauses ::= | {% 'comprehension.for' | 'let' iterator+ 'in' clauses %} | {% 'comprehension.when' | expr ';' clauses %} | {% 'comprehension.body' | expr %} iterator ::= | pattern '=' {% 'comprehension.for.range.upto' | expr ',' expr %} | pattern '=' {% 'comprehension.for.range.downto' | expr ',' expr %} | pattern '=' {% 'comprehension.for.in' | expr %} v} *) (** First, we define how to go from the nice AST to the OCaml AST; this is the [expr_of_...] family of expressions, culminating in [expr_of_comprehension_expr]. *) let expr_of_iterator = function | Range { start; stop; direction } -> Ast_of.wrap_jane_syntax [ "for" ; "range" ; (match direction with | Upto -> "upto" | Downto -> "downto") ] (Ast_helper.Exp.tuple [ start; stop ]) | In seq -> Ast_of.wrap_jane_syntax [ "for"; "in" ] seq ;; let expr_of_clause_binding { pattern; iterator; attributes } = Ast_helper.Vb.mk ~attrs:attributes pattern (expr_of_iterator iterator) ;; let expr_of_clause clause rest = match clause with | For iterators -> Ast_of.wrap_jane_syntax [ "for" ] (Ast_helper.Exp.let_ Nonrecursive (List.map expr_of_clause_binding iterators) rest) | When cond -> Ast_of.wrap_jane_syntax [ "when" ] (Ast_helper.Exp.sequence cond rest) ;; let expr_of_comprehension ~type_ { body; clauses } = (* We elect to wrap the body in a new AST node (here, [Pexp_lazy]) because it makes it so there is no AST node that can carry multiple Jane Syntax-related attributes in addition to user-written attributes. This choice simplifies the definition of [comprehension_expr_of_expr], as part of its contract is threading through the user-written attributes on the outermost node. *) Ast_of.wrap_jane_syntax type_ (Ast_helper.Exp.lazy_ (List.fold_right expr_of_clause clauses (Ast_of.wrap_jane_syntax [ "body" ] body))) ;; let expr_of ~loc cexpr = (* See Note [Wrapping with make_entire_jane_syntax] *) Expression.make_entire_jane_syntax ~loc feature (fun () -> match cexpr with | Cexp_list_comprehension comp -> expr_of_comprehension ~type_:[ "list" ] comp | Cexp_array_comprehension (amut, comp) -> expr_of_comprehension ~type_: [ "array" ; (match amut with | Mutable -> "mutable" | Immutable -> "immutable") ] comp) ;; (** Then, we define how to go from the OCaml AST to the nice AST; this is the [..._of_expr] family of expressions, culminating in [comprehension_expr_of_expr]. *) module Desugaring_error = struct type error = | Has_payload of payload | Bad_comprehension_embedding of string list | No_clauses let report_error ~loc = function | Has_payload payload -> Location.errorf ~loc "Comprehensions attribute has an unexpected payload:@;%a" (Printast.payload 0) payload | Bad_comprehension_embedding subparts -> Location.errorf ~loc "Unknown, unexpected, or malformed@ comprehension embedded term %a" Embedded_name.pp_quoted_name (Embedded_name.of_feature feature subparts) | No_clauses -> Location.errorf ~loc "Tried to desugar a comprehension with no clauses" ;; exception Error of Location.t * error let () = Location.register_error_of_exn (function | Error (loc, err) -> Some (report_error ~loc err) | _ -> None) ;; let raise expr err = raise (Error (expr.pexp_loc, err)) end (* Returns the expression node with the outermost Jane Syntax-related attribute removed. *) let expand_comprehension_extension_expr expr = let names, payload, attributes = Of_ast.unwrap_jane_syntax_attributes_exn ~loc:expr.pexp_loc expr.pexp_attributes in match payload with | PStr [] -> names, { expr with pexp_attributes = attributes } | _ -> Desugaring_error.raise expr (Has_payload payload) ;; let iterator_of_expr expr = match expand_comprehension_extension_expr expr with | [ "for"; "range"; "upto" ], { pexp_desc = Pexp_tuple [ start; stop ]; _ } -> Range { start; stop; direction = Upto } | [ "for"; "range"; "downto" ], { pexp_desc = Pexp_tuple [ start; stop ]; _ } -> Range { start; stop; direction = Downto } | [ "for"; "in" ], seq -> In seq | bad, _ -> Desugaring_error.raise expr (Bad_comprehension_embedding bad) ;; let clause_binding_of_vb { pvb_pat; pvb_expr; pvb_attributes; pvb_loc = _ } = { pattern = pvb_pat ; iterator = iterator_of_expr pvb_expr ; attributes = pvb_attributes } ;; let add_clause clause comp = { comp with clauses = clause :: comp.clauses } let comprehension_of_expr = let rec raw_comprehension_of_expr expr = match expand_comprehension_extension_expr expr with | [ "for" ], { pexp_desc = Pexp_let (Nonrecursive, iterators, rest); _ } -> add_clause (For (List.map clause_binding_of_vb iterators)) (raw_comprehension_of_expr rest) | [ "when" ], { pexp_desc = Pexp_sequence (cond, rest); _ } -> add_clause (When cond) (raw_comprehension_of_expr rest) | [ "body" ], body -> { body; clauses = [] } | bad, _ -> Desugaring_error.raise expr (Bad_comprehension_embedding bad) in fun expr -> match raw_comprehension_of_expr expr with | { body = _; clauses = [] } -> Desugaring_error.raise expr No_clauses | comp -> comp ;; (* Returns remaining unconsumed attributes on outermost expression *) let comprehension_expr_of_expr expr = let name, wrapper = expand_comprehension_extension_expr expr in let comp = match name, wrapper.pexp_desc with | [ "list" ], Pexp_lazy comp -> Cexp_list_comprehension (comprehension_of_expr comp) | [ "array"; "mutable" ], Pexp_lazy comp -> Cexp_array_comprehension (Mutable, comprehension_of_expr comp) | [ "array"; "immutable" ], Pexp_lazy comp -> (* assert_extension_enabled: See Note [Check for immutable extension in comprehensions code] *) assert_extension_enabled ~loc:expr.pexp_loc Immutable_arrays (); Cexp_array_comprehension (Immutable, comprehension_of_expr comp) | bad, _ -> Desugaring_error.raise expr (Bad_comprehension_embedding bad) in comp, wrapper.pexp_attributes ;; end (** Immutable arrays *) module Immutable_arrays = struct type nonrec expression = Iaexp_immutable_array of expression list type nonrec pattern = Iapat_immutable_array of pattern list let feature : Feature.t = Language_extension Immutable_arrays let expr_of ~loc = function | Iaexp_immutable_array elts -> (* See Note [Wrapping with make_entire_jane_syntax] *) Expression.make_entire_jane_syntax ~loc feature (fun () -> Ast_helper.Exp.array elts) ;; (* Returns remaining unconsumed attributes *) let of_expr expr = match expr.pexp_desc with | Pexp_array elts -> Iaexp_immutable_array elts, expr.pexp_attributes | _ -> failwith "Malformed immutable array expression" ;; let pat_of ~loc = function | Iapat_immutable_array elts -> (* See Note [Wrapping with make_entire_jane_syntax] *) Pattern.make_entire_jane_syntax ~loc feature (fun () -> Ast_helper.Pat.array elts) ;; (* Returns remaining unconsumed attributes *) let of_pat pat = match pat.ppat_desc with | Ppat_array elts -> Iapat_immutable_array elts, pat.ppat_attributes | _ -> failwith "Malformed immutable array pattern" ;; end module N_ary_functions = struct module Ext = struct let feature : Feature.t = Builtin end module Ast_of = Ast_of (Expression) (Ext) module Of_ast = Of_ast (Ext) open Ext type function_body = | Pfunction_body of expression | Pfunction_cases of case list * Location.t * attributes type function_param_desc = | Pparam_val of arg_label * expression option * pattern | Pparam_newtype of string loc * jkind_annotation option type function_param = { pparam_desc : function_param_desc ; pparam_loc : Location.t } type type_constraint = | Pconstraint of core_type | Pcoerce of core_type option * core_type type function_constraint = { mode_annotations : Mode_expr.t ; type_constraint : type_constraint } type expression = function_param list * function_constraint option * function_body (** An attribute of the form [@jane.erasable._builtin.*] that's relevant to n-ary functions. The "*" in the example is what we call the "suffix". See the below BNF for the meaning of the attributes. *) module Attribute_node = struct type after_fun = | Cases | Constraint_then_cases type t = | Top_level | Fun_then of after_fun | Mode_constraint of Mode_expr.t | Jkind_annotation of const_jkind loc (* We return an [of_suffix_result] from [of_suffix] rather than having [of_suffix] interpret the payload for two reasons: 1. It's nice to keep the string production / matching extremely visually simple so it's easy to check that [to_suffix_and_payload] and [of_suffix] correspond. 2. We want to raise a [Desugaring_error.Has_payload] in the case that a [No_payload t] has an improper payload, but this creates a dependency cycle between [Attribute_node] and [Desugaring_error]. Moving the interpretation of the payload to the caller of [of_suffix] breaks this cycle. *) type of_suffix_result = | No_payload of t | Payload of (payload -> loc:Location.t -> t) | Unknown_suffix let to_suffix_and_payload = function | Top_level -> [], None | Fun_then Cases -> [ "cases" ], None | Fun_then Constraint_then_cases -> [ "constraint"; "cases" ], None | Mode_constraint modes -> let payload = Mode_expr.payload_of modes in [ "mode_constraint" ], payload | Jkind_annotation jkind_annotation -> let payload = Jkind_annotation.Encode.as_payload jkind_annotation in [ "jkind_annotation" ], Some payload ;; let of_suffix suffix = match suffix with | [] -> No_payload Top_level | [ "cases" ] -> No_payload (Fun_then Cases) | [ "constraint"; "cases" ] -> No_payload (Fun_then Constraint_then_cases) | [ "mode_constraint" ] -> Payload (fun payload ~loc -> let modes = Mode_expr.of_payload payload ~loc in Mode_constraint modes) | [ "jkind_annotation" ] -> Payload (fun payload ~loc -> assert_extension_enabled ~loc Layouts (Stable : Language_extension.maturity); let jkind_annotation = Jkind_annotation.Decode.from_payload payload ~loc in Jkind_annotation jkind_annotation) | _ -> Unknown_suffix ;; let format ppf t = let suffix, _ = to_suffix_and_payload t in Embedded_name.pp_quoted_name ppf (Embedded_name.of_feature feature suffix) ;; end module Desugaring_error = struct type error = | Has_payload of payload | Expected_constraint_or_coerce | Expected_function_cases of Attribute_node.t | Expected_fun_or_newtype of Attribute_node.t | Expected_newtype_with_jkind_annotation of jkind_annotation | Parameterless_function let report_error ~loc = function | Has_payload payload -> Location.errorf ~loc "Syntactic arity attribute has an unexpected payload:@;%a" (Printast.payload 0) payload | Expected_constraint_or_coerce -> Location.errorf ~loc "Expected a Pexp_constraint or Pexp_coerce node at this position." | Expected_function_cases attribute -> Location.errorf ~loc "Expected a Pexp_function node in this position, as the enclosing Pexp_fun is \ annotated with %a." Attribute_node.format attribute | Expected_fun_or_newtype attribute -> Location.errorf ~loc "Only Pexp_fun or Pexp_newtype may carry the attribute %a." Attribute_node.format attribute | Expected_newtype_with_jkind_annotation annotation -> Location.errorf ~loc "Only Pexp_newtype may carry the attribute %a." Attribute_node.format (Attribute_node.Jkind_annotation annotation) | Parameterless_function -> Location.errorf ~loc "The expression is a Jane Syntax encoding of a function with no parameters, \ which is an invalid expression." ;; exception Error of Location.t * error let () = Location.register_error_of_exn (function | Error (loc, err) -> Some (report_error ~loc err) | _ -> None) ;; let raise_with_loc loc err = raise (Error (loc, err)) let raise expr err = raise (Error (expr.pexp_loc, err)) end (* The desugared-to-OCaml version of an n-ary function is described by the following BNF, where [{% '...' | expr %}] refers to the result of [Expression.make_jane_syntax] (via n_ary_function_expr) as described at the top of [jane_syntax_parsing.mli]. Within the '...' string, I use <...> brackets to denote string interpolation. {v (* The entry point. The encoding only puts attributes on: - [fun] nodes - constraint/coercion nodes, on the rare occasions that a constraint should be interpreted at the [local] mode This ensures that we rarely put attributes on the *body* of the function, which means that ppxes that move or transform the body of a function won't make Jane Syntax complain. *) n_ary_function ::= | nested_n_ary_function (* A function need not have [fun] params; it can be a function or a constrained function. These need not have extra attributes, except in the rare case that the function is constrained at the local mode. *) | pexp_function | constraint_with_mode_then(pexp_function) nested_n_ary_function ::= | fun_then(nested_n_ary_function) | fun_then(constraint_with_mode_then(expression)) | {% '_builtin.cases' | fun_then(pexp_function) } | {% '_builtin.constraint.cases' | fun_then(constraint_with_mode_then(pexp_function)) } | fun_then(expression) fun_then(body) ::= | 'fun' pattern '->' body (* Pexp_fun *) | 'fun' '(' 'type' ident ')' '->' body (* Pexp_newtype *) |{% '_builtin.jkind_annotation' | 'fun' '(' 'type' ident ')' '->' body %} (* Pexp_newtype *) pexp_function ::= | 'function' cases constraint_then(ast) ::= | ast (':' type)? ':>' type (* Pexp_coerce *) | ast ':' type (* Pexp_constraint *) constraint_with_mode_then(ast) ::= | constraint_then(ast) | {% '_builtin.local_constraint' | constraint_then(ast) %} v} *) let expand_n_ary_expr expr = match Of_ast.unwrap_jane_syntax_attributes expr.pexp_attributes with | Error (Not_this_embedding _ | Non_embedding) -> None | Ok (suffix, payload, attributes) -> let attribute_node = match Attribute_node.of_suffix suffix, payload with | No_payload t, PStr [] -> Some t | Payload f, payload -> Some (f payload ~loc:expr.pexp_loc) | No_payload _, payload -> Desugaring_error.raise expr (Has_payload payload) | Unknown_suffix, _ -> None in Option.map (fun x -> x, attributes) attribute_node ;; let require_function_cases expr ~arity_attribute = match expr.pexp_desc with | Pexp_function cases -> cases | _ -> Desugaring_error.raise expr (Expected_function_cases arity_attribute) ;; let constraint_modes expr : Mode_expr.t = match expand_n_ary_expr expr with | Some (Mode_constraint modes, _) -> modes | _ -> Mode_expr.empty ;; let check_constraint expr = match expr.pexp_desc with | Pexp_constraint (e, ty) -> let mode_annotations = constraint_modes expr in Some ({ mode_annotations; type_constraint = Pconstraint ty }, e) | Pexp_coerce (e, ty1, ty2) -> let mode_annotations = constraint_modes expr in Some ({ mode_annotations; type_constraint = Pcoerce (ty1, ty2) }, e) | _ -> None ;; let require_constraint expr = match check_constraint expr with | Some constraint_ -> constraint_ | None -> Desugaring_error.raise expr Expected_constraint_or_coerce ;; let check_param pexp_desc (pexp_loc : Location.t) ~jkind = match pexp_desc, jkind with | Pexp_fun (lbl, def, pat, body), None -> let pparam_loc : Location.t = { loc_ghost = true ; loc_start = pexp_loc.loc_start ; loc_end = pat.ppat_loc.loc_end } in let pparam_desc = Pparam_val (lbl, def, pat) in Some ({ pparam_desc; pparam_loc }, body) | Pexp_newtype (newtype, body), jkind -> (* This imperfectly estimates where a newtype parameter ends: it uses the end of the type name rather than the closing paren. The closing paren location is not tracked anywhere in the parsetree. We don't think merlin is affected. *) let pparam_loc : Location.t = { loc_ghost = true ; loc_start = pexp_loc.loc_start ; loc_end = newtype.loc.loc_end } in let pparam_desc = Pparam_newtype (newtype, jkind) in Some ({ pparam_desc; pparam_loc }, body) | _, None -> None | _, Some jkind -> Desugaring_error.raise_with_loc pexp_loc (Expected_newtype_with_jkind_annotation jkind) ;; let require_param pexp_desc pexp_loc ~arity_attribute ~jkind = match check_param pexp_desc pexp_loc ~jkind with | Some x -> x | None -> Desugaring_error.raise_with_loc pexp_loc (Expected_fun_or_newtype arity_attribute) ;; (* Should only be called on [Pexp_fun] and [Pexp_newtype]. *) let extract_fun_params = let open struct type continue_or_stop = | Continue of Parsetree.expression | Stop of function_constraint option * function_body end in (* Returns: the next parameter, together with whether there are possibly more parameters available ("Continue") or whether all parameters have been consumed ("Stop"). The returned attributes are the remaining unconsumed attributes on the Pexp_fun or Pexp_newtype node. The [jkind] parameter gives the jkind at which to interpret the type introduced by [expr = Pexp_newtype _]. It is only supplied in a recursive call to [extract_next_fun_param] in the event that it sees a [Jkind_annotation] attribute. *) let rec extract_next_fun_param expr ~jkind : (function_param * attributes) option * continue_or_stop = match expand_n_ary_expr expr with | None -> (match check_param expr.pexp_desc expr.pexp_loc ~jkind with | Some (param, body) -> Some (param, expr.pexp_attributes), Continue body | None -> None, Stop (None, Pfunction_body expr)) | Some (Top_level, _) -> None, Stop (None, Pfunction_body expr) | Some (Jkind_annotation next_jkind, unconsumed_attributes) -> extract_next_fun_param { expr with pexp_attributes = unconsumed_attributes } ~jkind:(Some next_jkind) | Some (Mode_constraint _, _unconsumed_attributes) -> (* We need not pass through any unconsumed attributes, as [Mode_constraint _] isn't the outermost Jane Syntax node: [extract_fun_params] took in [Pexp_fun] or [Pexp_newtype]. *) let function_constraint, body = require_constraint expr in None, Stop (Some function_constraint, Pfunction_body body) | Some ((Fun_then after_fun as arity_attribute), unconsumed_attributes) -> let param, body = require_param expr.pexp_desc expr.pexp_loc ~arity_attribute ~jkind in let continue_or_stop = match after_fun with | Cases -> let cases = require_function_cases body ~arity_attribute in let function_body = Pfunction_cases (cases, body.pexp_loc, body.pexp_attributes) in Stop (None, function_body) | Constraint_then_cases -> let function_constraint, body = require_constraint body in let cases = require_function_cases body ~arity_attribute in let function_body = Pfunction_cases (cases, body.pexp_loc, body.pexp_attributes) in Stop (Some function_constraint, function_body) in Some (param, unconsumed_attributes), continue_or_stop in let rec loop expr ~rev_params = let next_param, continue_or_stop = extract_next_fun_param expr ~jkind:None in let rev_params = match next_param with | None -> rev_params | Some (x, _) -> x :: rev_params in match continue_or_stop with | Continue body -> loop body ~rev_params | Stop (function_constraint, body) -> let params = List.rev rev_params in params, function_constraint, body in fun expr -> (match expr.pexp_desc with | Pexp_newtype _ | Pexp_fun _ -> () | _ -> Misc.fatal_error "called on something that isn't a newtype or fun"); let unconsumed_attributes = match extract_next_fun_param expr ~jkind:None with | Some (_, attributes), _ -> attributes | None, _ -> Desugaring_error.raise expr Parameterless_function in loop expr ~rev_params:[], unconsumed_attributes ;; (* Returns remaining unconsumed attributes on outermost expression *) let of_expr = let function_without_additional_params cases constraint_ loc : expression = (* If the outermost node is function cases, we place the attributes on the function node as a whole rather than on the [Pfunction_cases] body. *) [], constraint_, Pfunction_cases (cases, loc, []) in (* Hack: be more permissive toward a way that a ppx can mishandle an attribute, which is to duplicate the top-level Jane Syntax attribute. *) let rec remove_top_level_attributes expr = match expand_n_ary_expr expr with | Some (Top_level, unconsumed_attributes) -> remove_top_level_attributes { expr with pexp_attributes = unconsumed_attributes } | _ -> expr in fun expr -> let expr = remove_top_level_attributes expr in match expr.pexp_desc with | Pexp_fun _ | Pexp_newtype _ -> Some (extract_fun_params expr) | Pexp_function cases -> let n_ary = function_without_additional_params cases None expr.pexp_loc in Some (n_ary, expr.pexp_attributes) | _ -> (match check_constraint expr with | Some (constraint_, { pexp_desc = Pexp_function cases }) -> let n_ary = function_without_additional_params cases (Some constraint_) expr.pexp_loc in Some (n_ary, expr.pexp_attributes) | _ -> None) ;; let n_ary_function_expr ext x = let suffix, payload = Attribute_node.to_suffix_and_payload ext in Ast_of.wrap_jane_syntax ?payload suffix x ;; let expr_of = let add_param ?after_fun_attribute { pparam_desc; pparam_loc } body = let fun_ = let loc = { !Ast_helper.default_loc with loc_start = pparam_loc.loc_start } in match pparam_desc with | Pparam_val (label, default, pat) -> Ast_helper.Exp.fun_ label default pat body ~loc [@alert "-prefer_jane_syntax"] | Pparam_newtype (newtype, jkind) -> (match jkind with | None -> Ast_helper.Exp.newtype newtype body ~loc | Some jkind -> n_ary_function_expr (Jkind_annotation jkind) (Ast_helper.Exp.newtype newtype body ~loc)) in match after_fun_attribute with | None -> fun_ | Some after_fun -> n_ary_function_expr (Fun_then after_fun) fun_ in fun ~loc (params, constraint_, function_body) -> (* See Note [Wrapping with make_entire_jane_syntax] *) Expression.make_entire_jane_syntax ~loc feature (fun () -> let body = match function_body with | Pfunction_body body -> body | Pfunction_cases (cases, loc, attrs) -> Ast_helper.Exp.function_ cases ~loc ~attrs [@alert "-prefer_jane_syntax"] in let possibly_constrained_body = match constraint_ with | None -> body | Some { mode_annotations; type_constraint } -> let constrained_body = (* We can't call [Location.ghostify] here, as we need this file to build with the upstream compiler; see Note [Buildable with upstream] in jane_syntax.mli for details. *) let loc = { body.pexp_loc with loc_ghost = true } in match type_constraint with | Pconstraint ty -> Ast_helper.Exp.constraint_ body ty ~loc | Pcoerce (ty1, ty2) -> Ast_helper.Exp.coerce body ty1 ty2 ~loc in (match mode_annotations.txt with | _ :: _ -> n_ary_function_expr (Mode_constraint mode_annotations) constrained_body | [] -> constrained_body) in match params with | [] -> possibly_constrained_body | params -> let init_params, last_param = Misc.split_last params in let after_fun_attribute : Attribute_node.after_fun option = match constraint_, function_body with | Some _, Pfunction_cases _ -> Some Constraint_then_cases | None, Pfunction_cases _ -> Some Cases | Some _, Pfunction_body _ -> None | None, Pfunction_body _ -> None in let body_with_last_param = add_param last_param ?after_fun_attribute possibly_constrained_body in List.fold_right add_param init_params body_with_last_param) ;; end (** Labeled tuples *) module Labeled_tuples = struct module Ext = struct let feature : Feature.t = Language_extension Labeled_tuples end module Of_ast = Of_ast (Ext) include Ext type nonrec core_type = (string option * core_type) list type nonrec expression = (string option * expression) list type nonrec pattern = (string option * pattern) list * closed_flag let string_of_label = function | None -> "" | Some lbl -> lbl ;; let label_of_string = function | "" -> None | s -> Some s ;; let string_of_closed_flag = function | Closed -> "closed" | Open -> "open" ;; let closed_flag_of_string = function | "closed" -> Closed | "open" -> Open | _ -> failwith "bad closed flag" ;; module Desugaring_error = struct type error = | Malformed | Has_payload of payload let report_error ~loc = function | Malformed -> Location.errorf ~loc "Malformed embedded labeled tuple term" | Has_payload payload -> Location.errorf ~loc "Labeled tuples attribute has an unexpected payload:@;%a" (Printast.payload 0) payload ;; exception Error of Location.t * error let () = Location.register_error_of_exn (function | Error (loc, err) -> Some (report_error ~loc err) | _ -> None) ;; let raise loc err = raise (Error (loc, err)) end let expand_labeled_tuple_extension loc attrs = let names, payload, attrs = Of_ast.unwrap_jane_syntax_attributes_exn ~loc attrs in match payload with | PStr [] -> names, attrs | _ -> Desugaring_error.raise loc (Has_payload payload) ;; type 'a label_check_result = | No_labels of 'a list | At_least_one_label of (string option * 'a) list let check_for_any_label xs = if List.for_all (fun (lbl, _x) -> Option.is_none lbl) xs then No_labels (List.map snd xs) else At_least_one_label xs ;; let typ_of ~loc tl = match check_for_any_label tl with | No_labels tl -> Ast_helper.Typ.tuple ~loc tl | At_least_one_label tl -> (* See Note [Wrapping with make_entire_jane_syntax] *) Core_type.make_entire_jane_syntax ~loc feature (fun () -> let names = List.map (fun (label, _) -> string_of_label label) tl in Core_type.make_jane_syntax feature names @@ Ast_helper.Typ.tuple (List.map snd tl)) ;; (* Returns remaining unconsumed attributes *) let of_typ typ = let labels, ptyp_attributes = expand_labeled_tuple_extension typ.ptyp_loc typ.ptyp_attributes in match typ.ptyp_desc with | Ptyp_tuple components -> if List.length labels <> List.length components then Desugaring_error.raise typ.ptyp_loc Malformed; let labeled_components = List.map2 (fun s t -> label_of_string s, t) labels components in labeled_components, ptyp_attributes | _ -> Desugaring_error.raise typ.ptyp_loc Malformed ;; let expr_of ~loc el = match check_for_any_label el with | No_labels el -> Ast_helper.Exp.tuple ~loc el | At_least_one_label el -> (* See Note [Wrapping with make_entire_jane_syntax] *) Expression.make_entire_jane_syntax ~loc feature (fun () -> let names = List.map (fun (label, _) -> string_of_label label) el in Expression.make_jane_syntax feature names @@ Ast_helper.Exp.tuple (List.map snd el)) ;; (* Returns remaining unconsumed attributes *) let of_expr expr = let labels, pexp_attributes = expand_labeled_tuple_extension expr.pexp_loc expr.pexp_attributes in match expr.pexp_desc with | Pexp_tuple components -> if List.length labels <> List.length components then Desugaring_error.raise expr.pexp_loc Malformed; let labeled_components = List.map2 (fun s e -> label_of_string s, e) labels components in labeled_components, pexp_attributes | _ -> Desugaring_error.raise expr.pexp_loc Malformed ;; let pat_of = let make_jane_syntax ~loc pl closed = (* See Note [Wrapping with make_entire_jane_syntax] *) Pattern.make_entire_jane_syntax ~loc feature (fun () -> let names = List.map (fun (label, _) -> string_of_label label) pl in Pattern.make_jane_syntax feature (string_of_closed_flag closed :: names) @@ Ast_helper.Pat.tuple (List.map snd pl)) in fun ~loc (pl, closed) -> match closed with | Open -> make_jane_syntax ~loc pl closed | Closed -> (match check_for_any_label pl with | No_labels pl -> Ast_helper.Pat.tuple ~loc pl | At_least_one_label pl -> make_jane_syntax ~loc pl closed) ;; (* Returns remaining unconsumed attributes *) let of_pat pat = let labels, ppat_attributes = expand_labeled_tuple_extension pat.ppat_loc pat.ppat_attributes in match labels, pat.ppat_desc with | closed :: labels, Ppat_tuple components -> if List.length labels <> List.length components then Desugaring_error.raise pat.ppat_loc Malformed; let closed = closed_flag_of_string closed in let labeled_components = List.map2 (fun s e -> label_of_string s, e) labels components in (labeled_components, closed), ppat_attributes | _ -> Desugaring_error.raise pat.ppat_loc Malformed ;; end (** [include functor] *) module Include_functor = struct type signature_item = Ifsig_include_functor of include_description type structure_item = Ifstr_include_functor of include_declaration let feature : Feature.t = Language_extension Include_functor let sig_item_of ~loc = function | Ifsig_include_functor incl -> (* See Note [Wrapping with make_entire_jane_syntax] *) Signature_item.make_entire_jane_syntax ~loc feature (fun () -> Ast_helper.Sig.include_ incl) ;; let of_sig_item sigi = match sigi.psig_desc with | Psig_include incl -> Ifsig_include_functor incl | _ -> failwith "Malformed [include functor] in signature" ;; let str_item_of ~loc = function | Ifstr_include_functor incl -> (* See Note [Wrapping with make_entire_jane_syntax] *) Structure_item.make_entire_jane_syntax ~loc feature (fun () -> Ast_helper.Str.include_ incl) ;; let of_str_item stri = match stri.pstr_desc with | Pstr_include incl -> Ifstr_include_functor incl | _ -> failwith "Malformed [include functor] in structure" ;; end (** Module strengthening *) module Strengthen = struct type nonrec module_type = { mty : Parsetree.module_type ; mod_id : Longident.t Location.loc } let feature : Feature.t = Language_extension Module_strengthening (* Encoding: [S with M] becomes [functor (_ : S) -> (module M)], where the [(module M)] is a [Pmty_alias]. This isn't syntax we can write, but [(module M)] can be the inferred type for [M], so this should be fine. *) let mty_of ~loc { mty; mod_id } = (* See Note [Wrapping with make_entire_jane_syntax] *) Module_type.make_entire_jane_syntax ~loc feature (fun () -> Ast_helper.Mty.functor_ (Named (Location.mknoloc None, mty)) (Ast_helper.Mty.alias mod_id)) ;; (* Returns remaining unconsumed attributes *) let of_mty mty = match mty.pmty_desc with | Pmty_functor (Named (_, mty), { pmty_desc = Pmty_alias mod_id }) -> { mty; mod_id }, mty.pmty_attributes | _ -> failwith "Malformed strengthened module type" ;; end (** Layouts *) module Layouts = struct module Ext = struct let feature : Feature.t = Language_extension Layouts end include Ext module Of_ast = Of_ast (Ext) type constant = | Float of string * char option | Integer of string * char type nonrec expression = | Lexp_constant of constant | Lexp_newtype of string loc * jkind_annotation * expression type nonrec pattern = Lpat_constant of constant type nonrec core_type = | Ltyp_var of { name : string option ; jkind : jkind_annotation } | Ltyp_poly of { bound_vars : (string loc * jkind_annotation option) list ; inner_type : core_type } | Ltyp_alias of { aliased_type : core_type ; name : string option ; jkind : jkind_annotation } type nonrec extension_constructor = | Lext_decl of (string Location.loc * jkind_annotation option) list * constructor_arguments * Parsetree.core_type option (*******************************************************) (* Pretty-printing *) module Pprint = Jkinds_pprint (*******************************************************) (* Errors *) module Desugaring_error = struct type error = | Unexpected_wrapped_type of Parsetree.core_type | Unexpected_wrapped_ext of Parsetree.extension_constructor | Unexpected_attribute of string list | No_integer_suffix | Unexpected_constant of Parsetree.constant | Unexpected_wrapped_expr of Parsetree.expression | Unexpected_wrapped_pat of Parsetree.pattern (* Most things here are unprintable because we can't reference any [Printast] functions that aren't exposed by the upstream compiler, as we want this file to be compatible with the upstream compiler; see Note [Buildable with upstream] in jane_syntax.mli for details. *) let report_error ~loc = function | Unexpected_wrapped_type _typ -> Location.errorf ~loc "Layout attribute on wrong core type" | Unexpected_wrapped_ext _ext -> Location.errorf ~loc "Layout attribute on wrong extension constructor" | Unexpected_attribute names -> Location.errorf ~loc "Layout extension does not understand these attribute names:@;[%a]" (Format_doc.pp_print_list ~pp_sep:(fun ppf () -> Format_doc.fprintf ppf ";@ ") Format_doc.pp_print_text) names | No_integer_suffix -> Location.errorf ~loc "All unboxed integers require a suffix to determine their size." | Unexpected_constant _c -> Location.errorf ~loc "Unexpected unboxed constant" | Unexpected_wrapped_expr expr -> Location.errorf ~loc "Layout attribute on wrong expression:@;%a" (Printast.expression 0) expr | Unexpected_wrapped_pat _pat -> Location.errorf ~loc "Layout attribute on wrong pattern" ;; exception Error of Location.t * error let () = Location.register_error_of_exn (function | Error (loc, err) -> Some (report_error ~loc err) | _ -> None) ;; let raise ~loc err = raise (Error (loc, err)) end module Encode = Jkind_annotation.Encode module Decode = Jkind_annotation.Decode (*******************************************************) (* Constants *) let constant_of = function | Float (x, suffix) -> Pconst_float (x, suffix) | Integer (x, suffix) -> Pconst_integer (x, Some suffix) ;; let of_constant ~loc = function | Pconst_float (x, suffix) -> Float (x, suffix) | Pconst_integer (x, Some suffix) -> Integer (x, suffix) | Pconst_integer (_, None) -> Desugaring_error.raise ~loc No_integer_suffix | const -> Desugaring_error.raise ~loc (Unexpected_constant const) ;; (*******************************************************) (* Encoding expressions *) let expr_of ~loc expr = let module Ast_of = Ast_of (Expression) (Ext) in (* See Note [Wrapping with make_entire_jane_syntax] *) Expression.make_entire_jane_syntax ~loc feature (fun () -> match expr with | Lexp_constant c -> let constant = constant_of c in Ast_of.wrap_jane_syntax [ "unboxed" ] @@ Ast_helper.Exp.constant constant | Lexp_newtype (name, jkind, inner_expr) -> let payload = Encode.as_payload jkind in Ast_of.wrap_jane_syntax [ "newtype" ] ~payload @@ Ast_helper.Exp.newtype name inner_expr) ;; (*******************************************************) (* Desugaring expressions *) let of_expr expr = let loc = expr.pexp_loc in let names, payload, attributes = Of_ast.unwrap_jane_syntax_attributes_exn ~loc expr.pexp_attributes in let lexpr = match names with | [ "unboxed" ] -> (match expr.pexp_desc with | Pexp_constant const -> Lexp_constant (of_constant ~loc const) | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_expr expr)) | [ "newtype" ] -> let jkind = Decode.from_payload ~loc payload in (match expr.pexp_desc with | Pexp_newtype (name, inner_expr) -> Lexp_newtype (name, jkind, inner_expr) | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_expr expr)) | _ -> Desugaring_error.raise ~loc (Unexpected_attribute names) in lexpr, attributes ;; (*******************************************************) (* Encoding patterns *) let pat_of ~loc t = Pattern.make_entire_jane_syntax ~loc feature (fun () -> match t with | Lpat_constant c -> let constant = constant_of c in Ast_helper.Pat.constant constant) ;; (*******************************************************) (* Desugaring patterns *) let of_pat pat = let loc = pat.ppat_loc in let lpat = match pat.ppat_desc with | Ppat_constant const -> Lpat_constant (of_constant ~loc const) | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_pat pat) in lpat, pat.ppat_attributes ;; (*******************************************************) (* Encoding types *) module Type_of = Ast_of (Core_type) (Ext) let type_of ~loc typ = let exception No_wrap_necessary of Parsetree.core_type in try (* See Note [Wrapping with make_entire_jane_syntax] *) Core_type.make_entire_jane_syntax ~loc feature (fun () -> match typ with | Ltyp_var { name; jkind } -> let payload = Encode.as_payload jkind in Type_of.wrap_jane_syntax [ "var" ] ~payload @@ (match name with | None -> Ast_helper.Typ.any ~loc () | Some name -> Ast_helper.Typ.var ~loc name) | Ltyp_poly { bound_vars; inner_type } -> let var_names, jkinds = List.split bound_vars in (* Pass the loc because we don't want a ghost location here *) let tpoly = Ast_helper.Typ.poly ~loc var_names inner_type in if List.for_all Option.is_none jkinds then raise (No_wrap_necessary tpoly) else ( let payload = Encode.option_list_as_payload jkinds in Type_of.wrap_jane_syntax [ "poly" ] ~payload tpoly) | Ltyp_alias { aliased_type; name; jkind } -> let payload = Encode.as_payload jkind in let has_name, inner_typ = match name with | None -> "anon", aliased_type | Some name -> "named", Ast_helper.Typ.alias aliased_type name in Type_of.wrap_jane_syntax [ "alias"; has_name ] ~payload inner_typ) with | No_wrap_necessary result_type -> result_type ;; (*******************************************************) (* Desugaring types *) let of_type typ = let loc = typ.ptyp_loc in let names, payload, attributes = Of_ast.unwrap_jane_syntax_attributes_exn ~loc typ.ptyp_attributes in let lty = match names with | [ "var" ] -> let jkind = Decode.from_payload ~loc payload in (match typ.ptyp_desc with | Ptyp_any -> Ltyp_var { name = None; jkind } | Ptyp_var name -> Ltyp_var { name = Some name; jkind } | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_type typ)) | [ "poly" ] -> (match typ.ptyp_desc with | Ptyp_poly (var_names, inner_type) -> let bound_vars = Decode.bound_vars_from_vars_and_payload ~loc var_names payload in Ltyp_poly { bound_vars; inner_type } | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_type typ)) | [ "alias"; "anon" ] -> let jkind = Decode.from_payload ~loc payload in Ltyp_alias { aliased_type = { typ with ptyp_attributes = attributes }; name = None; jkind } | [ "alias"; "named" ] -> let jkind = Decode.from_payload ~loc payload in (match typ.ptyp_desc with | Ptyp_alias (inner_typ, name) -> Ltyp_alias { aliased_type = inner_typ; name = Some name; jkind } | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_type typ)) | _ -> Desugaring_error.raise ~loc (Unexpected_attribute names) in lty, attributes ;; (*******************************************************) (* Encoding extension constructor *) module Ext_ctor_of = Ast_of (Extension_constructor) (Ext) let extension_constructor_of ~loc ~name ?info ?docs ext = (* using optional parameters to hook into existing defaulting in [Ast_helper.Te.decl], which seems unwise to duplicate *) let exception No_wrap_necessary of Parsetree.extension_constructor in try (* See Note [Wrapping with make_entire_jane_syntax] *) Extension_constructor.make_entire_jane_syntax ~loc feature (fun () -> match ext with | Lext_decl (bound_vars, args, res) -> let vars, jkinds = List.split bound_vars in let ext_ctor = (* Pass ~loc here, because the constructor declaration is not a ghost *) Ast_helper.Te.decl ~loc ~vars ~args ?info ?docs ?res name in if List.for_all Option.is_none jkinds then raise (No_wrap_necessary ext_ctor) else ( let payload = Encode.option_list_as_payload jkinds in Ext_ctor_of.wrap_jane_syntax [ "ext" ] ~payload ext_ctor)) with | No_wrap_necessary ext_ctor -> ext_ctor ;; (*******************************************************) (* Desugaring extension constructor *) let of_extension_constructor ext = let loc = ext.pext_loc in let names, payload, attributes = Of_ast.unwrap_jane_syntax_attributes_exn ~loc ext.pext_attributes in let lext = match names with | [ "ext" ] -> (match ext.pext_kind with | Pext_decl (var_names, args, res) -> let bound_vars = Decode.bound_vars_from_vars_and_payload ~loc var_names payload in Lext_decl (bound_vars, args, res) | _ -> Desugaring_error.raise ~loc (Unexpected_wrapped_ext ext)) | _ -> Desugaring_error.raise ~loc (Unexpected_attribute names) in lext, attributes ;; (*********************************************************) (* Constructing a [constructor_declaration] with jkinds *) module Ctor_decl_of = Ast_of (Constructor_declaration) (Ext) let constructor_declaration_of ~loc ~attrs ~info ~vars_jkinds ~args ~res name = let vars, jkinds = List.split vars_jkinds in let ctor_decl = Ast_helper.Type.constructor ~loc ~info ~vars ~args ?res name in let ctor_decl = if List.for_all Option.is_none jkinds then ctor_decl else ( let payload = Encode.option_list_as_payload jkinds in Constructor_declaration.make_entire_jane_syntax ~loc feature (fun () -> Ctor_decl_of.wrap_jane_syntax [ "vars" ] ~payload ctor_decl)) in (* Performance hack: save an allocation if [attrs] is empty. *) match attrs with | [] -> ctor_decl | _ :: _ as attrs -> (* See Note [Outer attributes at end] *) { ctor_decl with pcd_attributes = ctor_decl.pcd_attributes @ attrs } ;; let of_constructor_declaration_internal (feat : Feature.t) ctor_decl = match feat with | Language_extension Layouts -> let loc = ctor_decl.pcd_loc in let names, payload, attributes = Of_ast.unwrap_jane_syntax_attributes_exn ~loc ctor_decl.pcd_attributes in let vars_jkinds = match names with | [ "vars" ] -> Decode.bound_vars_from_vars_and_payload ~loc ctor_decl.pcd_vars payload | _ -> Desugaring_error.raise ~loc (Unexpected_attribute names) in Some (vars_jkinds, attributes) | _ -> None ;; let of_constructor_declaration = Constructor_declaration.make_of_ast ~of_ast_internal:of_constructor_declaration_internal ;; (*********************************************************) (* Constructing a [type_declaration] with jkinds *) module Type_decl_of = Ast_of (Type_declaration) (Ext) let type_declaration_of ~loc ~attrs ~docs ~text ~params ~cstrs ~kind ~priv ~manifest ~jkind name = let type_decl = Ast_helper.Type.mk ~loc ~docs ?text ~params ~cstrs ~kind ~priv ?manifest name in let type_decl = match jkind with | None -> type_decl | Some jkind -> Type_declaration.make_entire_jane_syntax ~loc feature (fun () -> let payload = Encode.as_payload jkind in Type_decl_of.wrap_jane_syntax [ "annot" ] ~payload type_decl) in (* Performance hack: save an allocation if [attrs] is empty. *) match attrs with | [] -> type_decl | _ :: _ as attrs -> (* See Note [Outer attributes at end] *) { type_decl with ptype_attributes = type_decl.ptype_attributes @ attrs } ;; let of_type_declaration_internal (feat : Feature.t) type_decl = match feat with | Language_extension Layouts -> let loc = type_decl.ptype_loc in let names, payload, attributes = Of_ast.unwrap_jane_syntax_attributes_exn ~loc type_decl.ptype_attributes in let jkind_annot = match names with | [ "annot" ] -> Decode.from_payload ~loc payload | _ -> Desugaring_error.raise ~loc (Unexpected_attribute names) in Some (jkind_annot, attributes) | _ -> None ;; let of_type_declaration = Type_declaration.make_of_ast ~of_ast_internal:of_type_declaration_internal ;; end (******************************************************************************) (** The interface to our novel syntax, which we export *) module type AST = sig type t type ast val of_ast : ast -> t option end module Core_type = struct type t = | Jtyp_layout of Layouts.core_type | Jtyp_tuple of Labeled_tuples.core_type let of_ast_internal (feat : Feature.t) typ = match feat with | Language_extension Layouts -> let typ, attrs = Layouts.of_type typ in Some (Jtyp_layout typ, attrs) | Language_extension Labeled_tuples -> let typ, attrs = Labeled_tuples.of_typ typ in Some (Jtyp_tuple typ, attrs) | _ -> None ;; let of_ast = Core_type.make_of_ast ~of_ast_internal let core_type_of ~loc ~attrs t = let core_type = match t with | Jtyp_layout x -> Layouts.type_of ~loc x | Jtyp_tuple x -> Labeled_tuples.typ_of ~loc x in (* Performance hack: save an allocation if [attrs] is empty. *) match attrs with | [] -> core_type | _ :: _ as attrs -> (* See Note [Outer attributes at end] *) { core_type with ptyp_attributes = core_type.ptyp_attributes @ attrs } ;; end module Constructor_argument = struct type t = | let of_ast_internal (feat : Feature.t) _carg = match feat with | _ -> None ;; let of_ast = Constructor_argument.make_of_ast ~of_ast_internal end module Expression = struct 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 let of_ast_internal (feat : Feature.t) expr = match feat with | Language_extension Comprehensions -> let expr, attrs = Comprehensions.comprehension_expr_of_expr expr in Some (Jexp_comprehension expr, attrs) | Language_extension Immutable_arrays -> let expr, attrs = Immutable_arrays.of_expr expr in Some (Jexp_immutable_array expr, attrs) | Language_extension Layouts -> let expr, attrs = Layouts.of_expr expr in Some (Jexp_layout expr, attrs) | Builtin -> (match N_ary_functions.of_expr expr with | Some (expr, attrs) -> Some (Jexp_n_ary_function expr, attrs) | None -> None) | Language_extension Labeled_tuples -> let expr, attrs = Labeled_tuples.of_expr expr in Some (Jexp_tuple expr, attrs) | _ -> None ;; let of_ast = Expression.make_of_ast ~of_ast_internal let expr_of ~loc ~attrs t = let expr = match t with | Jexp_comprehension x -> Comprehensions.expr_of ~loc x | Jexp_immutable_array x -> Immutable_arrays.expr_of ~loc x | Jexp_layout x -> Layouts.expr_of ~loc x | Jexp_n_ary_function x -> N_ary_functions.expr_of ~loc x | Jexp_tuple x -> Labeled_tuples.expr_of ~loc x in (* Performance hack: save an allocation if [attrs] is empty. *) match attrs with | [] -> expr | _ :: _ as attrs -> (* See Note [Outer attributes at end] *) { expr with pexp_attributes = expr.pexp_attributes @ attrs } ;; end module Pattern = struct type t = | Jpat_immutable_array of Immutable_arrays.pattern | Jpat_layout of Layouts.pattern | Jpat_tuple of Labeled_tuples.pattern let of_ast_internal (feat : Feature.t) pat = match feat with | Language_extension Immutable_arrays -> let expr, attrs = Immutable_arrays.of_pat pat in Some (Jpat_immutable_array expr, attrs) | Language_extension Layouts -> let pat, attrs = Layouts.of_pat pat in Some (Jpat_layout pat, attrs) | Language_extension Labeled_tuples -> let expr, attrs = Labeled_tuples.of_pat pat in Some (Jpat_tuple expr, attrs) | _ -> None ;; let of_ast = Pattern.make_of_ast ~of_ast_internal let pat_of ~loc ~attrs t = let pat = match t with | Jpat_immutable_array x -> Immutable_arrays.pat_of ~loc x | Jpat_layout x -> Layouts.pat_of ~loc x | Jpat_tuple x -> Labeled_tuples.pat_of ~loc x in (* Performance hack: save an allocation if [attrs] is empty. *) match attrs with | [] -> pat | _ :: _ as attrs -> (* See Note [Outer attributes at end] *) { pat with ppat_attributes = pat.ppat_attributes @ attrs } ;; end module Module_type = struct type t = Jmty_strengthen of Strengthen.module_type let of_ast_internal (feat : Feature.t) mty = match feat with | Language_extension Module_strengthening -> let mty, attrs = Strengthen.of_mty mty in Some (Jmty_strengthen mty, attrs) | _ -> None ;; let of_ast = Module_type.make_of_ast ~of_ast_internal let mty_of ~loc ~attrs t = let mty = match t with | Jmty_strengthen x -> Strengthen.mty_of ~loc x in (* Performance hack: save an allocation if [attrs] is empty. *) match attrs with | [] -> mty | _ :: _ as attrs -> (* See Note [Outer attributes at end] *) { mty with pmty_attributes = mty.pmty_attributes @ attrs } ;; end module Signature_item = struct type t = Jsig_include_functor of Include_functor.signature_item let of_ast_internal (feat : Feature.t) sigi = match feat with | Language_extension Include_functor -> Some (Jsig_include_functor (Include_functor.of_sig_item sigi)) | _ -> None ;; let of_ast = Signature_item.make_of_ast ~of_ast_internal end module Structure_item = struct type t = Jstr_include_functor of Include_functor.structure_item let of_ast_internal (feat : Feature.t) stri = match feat with | Language_extension Include_functor -> Some (Jstr_include_functor (Include_functor.of_str_item stri)) | _ -> None ;; let of_ast = Structure_item.make_of_ast ~of_ast_internal end module Extension_constructor = struct type t = Jext_layout of Layouts.extension_constructor let of_ast_internal (feat : Feature.t) ext = match feat with | Language_extension Layouts -> let ext, attrs = Layouts.of_extension_constructor ext in Some (Jext_layout ext, attrs) | _ -> None ;; let of_ast = Extension_constructor.make_of_ast ~of_ast_internal let extension_constructor_of ~loc ~name ~attrs ?info ?docs t = let ext_ctor = match t with | Jext_layout lext -> Layouts.extension_constructor_of ~loc ~name ?info ?docs lext in (* Performance hack: save an allocation if [attrs] is empty. *) match attrs with | [] -> ext_ctor | _ :: _ as attrs -> (* See Note [Outer attributes at end] *) { ext_ctor with pext_attributes = ext_ctor.pext_attributes @ attrs } ;; end ppxlib_jane-0.17.2/src/jane_syntax.mli000066400000000000000000000601021471547060100177150ustar00rootroot00000000000000(*_ 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 *) (** See the comment on [expression]. *) type function_body = | Pfunction_body of Parsetree.expression | Pfunction_cases of Parsetree.case list * Location.t * Parsetree.attributes (** In [Pfunction_cases (_, loc, attrs)], the location extends from the start of the [function] keyword to the end of the last case. The compiler will only use typechecking-related attributes from [attrs], e.g. enabling or disabling a warning. *) 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 } type type_constraint = | Pconstraint of Parsetree.core_type | Pcoerce of Parsetree.core_type option * Parsetree.core_type (** 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 : 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 * 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 : 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 ppxlib_jane-0.17.2/src/jane_syntax_parsing.ml000066400000000000000000000771501471547060100213020ustar00rootroot00000000000000(*_ 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) ppxlib_jane-0.17.2/src/jane_syntax_parsing.mli000066400000000000000000000307501471547060100214460ustar00rootroot00000000000000(*_ 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 ppxlib_jane-0.17.2/src/language_extension.ml000066400000000000000000000001261471547060100211000ustar00rootroot00000000000000include Language_extension_kernel let is_enabled _ = true let is_at_least _ _ = true ppxlib_jane-0.17.2/src/language_extension.mli000066400000000000000000000005521471547060100212540ustar00rootroot00000000000000(** 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 *) ppxlib_jane-0.17.2/src/language_extension_kernel.ml000066400000000000000000000065001471547060100224420ustar00rootroot00000000000000(*_ 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 ppxlib_jane-0.17.2/src/language_extension_kernel.mli000066400000000000000000000044631471547060100226210ustar00rootroot00000000000000(*_ 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 ppxlib_jane-0.17.2/src/ppxlib_jane.ml000066400000000000000000000003231471547060100175130ustar00rootroot00000000000000module 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 ppxlib_jane-0.17.2/src/shadow_compiler_distribution.ml000066400000000000000000000033741471547060100232070ustar00rootroot00000000000000(* 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