From 3c02628306440d805268d28c7124681b9fb52ada Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 19 Sep 2023 12:19:43 +0200 Subject: [PATCH 01/19] Enable 'parse-docstrings' in the default profile (#2390) --- .ocamlformat | 1 - CHANGES.md | 5 +++++ doc/manpage_ocamlformat.mld | 2 +- lib/Conf.ml | 2 +- test/cli/print_config.t | 4 ++-- 5 files changed, 9 insertions(+), 5 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index ad952810fe..a4a98a28a7 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,6 +1,5 @@ profile = ocamlformat break-cases = fit margin = 77 -parse-docstrings = true wrap-comments = true line-endings = lf diff --git a/CHANGES.md b/CHANGES.md index 2594d2cb1c..56d165ecdf 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -6,6 +6,11 @@ profile. This started with version 0.26.0. ## unreleased +### Changed + +- Documentation comments are now formatted by default (#2390, @Julow) + Use the option `parse-docstrings = false` to disable. + ### Fixed - Remove trailing space inside a wrapping empty signature (#2443, @Julow) diff --git a/doc/manpage_ocamlformat.mld b/doc/manpage_ocamlformat.mld index ffbf60bccf..2977fddff3 100644 --- a/doc/manpage_ocamlformat.mld +++ b/doc/manpage_ocamlformat.mld @@ -394,7 +394,7 @@ OPTIONS (CODE FORMATTING STYLE) multi-line-only. --parse-docstrings - Parse and format docstrings. The flag is unset by default. + Parse and format docstrings. The flag is set by default. --parse-toplevel-phrases Parse and format toplevel phrases and their output. The flag is diff --git a/lib/Conf.ml b/lib/Conf.ml index bfd5fabe05..88305fd889 100644 --- a/lib/Conf.ml +++ b/lib/Conf.ml @@ -96,7 +96,7 @@ let conventional_profile from = ; parens_ite= elt false ; parens_tuple= elt `Always ; parens_tuple_patterns= elt `Multi_line_only - ; parse_docstrings= elt false + ; parse_docstrings= elt true ; parse_toplevel_phrases= elt false ; sequence_blank_line= elt `Preserve_one ; sequence_style= elt `Terminator diff --git a/test/cli/print_config.t b/test/cli/print_config.t index 812d86794a..278468c55f 100644 --- a/test/cli/print_config.t +++ b/test/cli/print_config.t @@ -60,7 +60,7 @@ No redundant values: parens-ite=false (profile conventional (file .ocamlformat:1)) parens-tuple=always (profile conventional (file .ocamlformat:1)) parens-tuple-patterns=multi-line-only (profile conventional (file .ocamlformat:1)) - parse-docstrings=false (profile conventional (file .ocamlformat:1)) + parse-docstrings=true (profile conventional (file .ocamlformat:1)) parse-toplevel-phrases=false (profile conventional (file .ocamlformat:1)) sequence-blank-line=preserve-one (profile conventional (file .ocamlformat:1)) sequence-style=terminator (profile conventional (file .ocamlformat:1)) @@ -138,7 +138,7 @@ Redundant values from the conventional profile: parens-ite=false (profile conventional (file .ocamlformat:1)) parens-tuple=always (profile conventional (file .ocamlformat:1)) parens-tuple-patterns=multi-line-only (profile conventional (file .ocamlformat:1)) - parse-docstrings=false (profile conventional (file .ocamlformat:1)) + parse-docstrings=true (profile conventional (file .ocamlformat:1)) parse-toplevel-phrases=false (profile conventional (file .ocamlformat:1)) sequence-blank-line=preserve-one (profile conventional (file .ocamlformat:1)) sequence-style=terminator (profile conventional (file .ocamlformat:1)) From f9af431c76f00422a51c63affadb169f2ff2aa8a Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Tue, 19 Sep 2023 15:42:15 +0200 Subject: [PATCH 02/19] Improvements to the preview script (#2431) * preview_new_release: Remove alcotest and tezos * preview_new_release: Option to apply a previous version first An executable can be passed to the new `-b` option, it will be applied in a first pass and the result will be commited. This ensures that the preview commit shows only the diff caused by the new version. --- tools/preview_new_release.sh | 50 ++++++++++++++++++++++++++---------- tools/projects.data | 2 -- 2 files changed, 37 insertions(+), 15 deletions(-) diff --git a/tools/preview_new_release.sh b/tools/preview_new_release.sh index ba16021296..68b3faa80a 100755 --- a/tools/preview_new_release.sh +++ b/tools/preview_new_release.sh @@ -7,10 +7,11 @@ github_prefix_set=0 gitlab_prefix_set=0 version_set=0 prefix_set=0 +prev_binary_set=0 function usage() { - echo "usage: $0 -u -y -v -p " + echo "usage: $0 -u -y -v -p -b " echo "Url prefix is of the form 'git@github.com:my_user'." } @@ -28,7 +29,22 @@ function uncomment_version() sed -i --follow-symlinks -e "s/^#\(version.*\)$/\1$version/" $file } -while getopts ":u:y:v:p:" opt; do +# Apply ocamlformat on a project, update the '.ocamlformat' and commit. +function apply_fmt() +{ + local version=$1 commit_msg=$2 + echo "Applying version $version" + comment_version .ocamlformat + $dune build @fmt --auto-promote &> "$log_dir/$project.log" || true + uncomment_version "$version" .ocamlformat + if ! git diff --shortstat --exit-code; then + git commit --quiet --all -m "$commit_msg" + IGNORE_REVS+=("# Upgrade to OCamlformat $version") + IGNORE_REVS+=("$(git rev-parse HEAD)") + fi +} + +while getopts ":u:y:v:p:b:" opt; do case "$opt" in u) github_prefix=$OPTARG @@ -46,6 +62,10 @@ while getopts ":u:y:v:p:" opt; do prefix=$OPTARG prefix_set=1 ;; + b) + prev_binary=$(realpath $OPTARG) + prev_binary_set=1 + ;; *) usage exit 1 @@ -76,7 +96,7 @@ mkdir -p "$log_dir" "$bin_dir" # a directory that will not change echo "Building OCamlformat" dune build @install -cp -L _build/install/default/bin/ocamlformat "$bin_dir/ocamlformat" +cp -L _build/install/default/bin/ocamlformat "$bin_dir/ocamlformat-next" PATH=$bin_dir:$PATH # Options in 'opts' are enclosed in '<>' to allow safe checks that don't @@ -114,14 +134,20 @@ while IFS=, read git_platform namespace project opts; do *) dune=dune ;; esac - comment_version .ocamlformat - $dune build @fmt --auto-promote &> "$log_dir/$project.log" || true - uncomment_version "$version" .ocamlformat + # Lines to insert into .git-blame-ignore-revs. Updated by [apply_fmt]. + IGNORE_REVS=() + + # Do a pass with the previous version. + if [[ $prev_binary_set -eq 1 ]]; then + ln -sf "$prev_binary" "$bin_dir/ocamlformat" + prev_version=$(ocamlformat --version) + apply_fmt "$prev_version" "Upgrade to OCamlformat $prev_version" + fi - git diff --shortstat - git commit --quiet --all -m "Preview: Upgrade to OCamlformat $version (unreleased) + ln -sf "ocamlformat-next" "$bin_dir/ocamlformat" + apply_fmt "$version" "Preview: Upgrade to OCamlformat $version (unreleased) -The aim of this commit is to gather feedback. +The aim of this preview is to gather feedback. Changelog can be found here: https://github.com/ocaml-ppx/ocamlformat/blob/main/CHANGES.md" @@ -129,10 +155,8 @@ Changelog can be found here: https://github.com/ocaml-ppx/ocamlformat/blob/main/ "tezos/tezos") bash scripts/lint.sh --update-ocamlformat ;; esac - if ! [[ $opts = *""* ]]; then - # Update .git-blame-ignore-revs - ( echo "# Upgrade to OCamlformat $version" - git rev-parse HEAD ) >> .git-blame-ignore-revs + if ! [[ $opts = *""* ]] && [[ "${#IGNORE_REVS}" -gt 0 ]]; then + printf "%s\n" "${IGNORE_REVS[@]}" >> .git-blame-ignore-revs git add .git-blame-ignore-revs git commit --quiet -m "Update .git-blame-ignore-revs" fi diff --git a/tools/projects.data b/tools/projects.data index 5bd8beb4fb..d29db4eca3 100644 --- a/tools/projects.data +++ b/tools/projects.data @@ -1,4 +1,3 @@ -github,mirage,alcotest, github,mirage,irmin, github,mirage,mirage, github,ocaml,dune, @@ -9,4 +8,3 @@ github,ocsigen,js_of_ocaml, github,realworldocaml,mdx, github,tarides,dune-release, github,tarides,ocaml-platform-installer, -gitlab,tezos,tezos, From b28958bea016921cdc06231ae103466e9095420b Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Wed, 20 Sep 2023 16:55:35 +0200 Subject: [PATCH 03/19] Remove .mli files in vendored parsers (#2449) These files slow down backporting upstream changes as well as making further changes to the extended parser. --- vendor/parser-extended/ast_helper.mli | 508 -------------------------- vendor/parser-extended/ast_mapper.mli | 121 ------ vendor/parser-extended/docstrings.mli | 223 ----------- vendor/parser-extended/parse.mli | 110 ------ vendor/parser-extended/printast.mli | 54 --- vendor/parser-standard/ast_helper.mli | 499 ------------------------- vendor/parser-standard/ast_mapper.ml | 2 + vendor/parser-standard/ast_mapper.mli | 211 ----------- vendor/parser-standard/docstrings.mli | 223 ----------- vendor/parser-standard/parse.mli | 110 ------ vendor/parser-standard/printast.mli | 34 -- 11 files changed, 2 insertions(+), 2093 deletions(-) delete mode 100644 vendor/parser-extended/ast_helper.mli delete mode 100644 vendor/parser-extended/ast_mapper.mli delete mode 100644 vendor/parser-extended/docstrings.mli delete mode 100644 vendor/parser-extended/parse.mli delete mode 100644 vendor/parser-extended/printast.mli delete mode 100644 vendor/parser-standard/ast_helper.mli delete mode 100644 vendor/parser-standard/ast_mapper.mli delete mode 100644 vendor/parser-standard/docstrings.mli delete mode 100644 vendor/parser-standard/parse.mli delete mode 100644 vendor/parser-standard/printast.mli diff --git a/vendor/parser-extended/ast_helper.mli b/vendor/parser-extended/ast_helper.mli deleted file mode 100644 index fd28c99b11..0000000000 --- a/vendor/parser-extended/ast_helper.mli +++ /dev/null @@ -1,508 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** Helpers to produce Parsetree fragments - - {b Warning} This module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Asttypes -open Docstrings -open Parsetree - -type 'a with_loc = 'a Location.loc -type loc = Location.t - -type lid = Longident.t with_loc -type str = string with_loc -type str_opt = string option with_loc -type attrs = attribute list - -(** {1 Default locations} *) - -val default_loc: loc ref - (** Default value for all optional location arguments. *) - -val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - -(** {1 Constants} *) - -module Const : sig - val mk: ?loc:loc -> constant_desc -> constant - - val char : ?loc:loc -> char -> string -> constant - val string : - ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant - val integer : ?loc:loc -> ?suffix:char -> string -> constant - val int : ?loc:loc -> ?suffix:char -> int -> constant - val int32 : ?loc:loc -> ?suffix:char -> int32 -> constant - val int64 : ?loc:loc -> ?suffix:char -> int64 -> constant - val nativeint : ?loc:loc -> ?suffix:char -> nativeint -> constant - val float : ?loc:loc -> ?suffix:char -> string -> constant -end - -(** {1 Attributes} *) -module Attr : sig - val mk: ?loc:loc -> str -> payload -> attribute -end - -(** {1 Core language} *) - -(** Type expressions *) -module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arrow_param list -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> obj_closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> str -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> variant_var list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - end - -(** Patterns *) -module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> - lid -> (str list * pattern) option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> variant_var -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs - -> (lid * core_type option * pattern option) list - -> obj_closed_flag -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val list: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> package_type option - -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - val cons: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - end - -(** Expressions *) -module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> value_bindings -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> variant_var -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs - -> (lid * (core_type option * core_type option) * expression option) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> if_branch list - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val indexop_access: ?loc:loc -> ?attrs:attrs - -> expression -> indexop_access_kind -> paren_kind -> expression option - -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt - -> functor_parameter with_loc list -> module_expr - -> expression -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> package_type option - -> expression - val open_: ?loc:loc -> ?attrs:attrs -> lid -> expression -> expression - val letopen: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression - -> expression - val letop: ?loc:loc -> ?attrs:attrs -> binding_op - -> binding_op list -> expression -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - val binding_op: str -> pattern -> expression -> loc -> binding_op - val hole: ?loc:loc -> ?attrs:attrs -> unit -> expression - val beginend: ?loc:loc -> ?attrs:attrs -> expression -> expression - val parens: ?loc:loc -> ?attrs:attrs -> expression -> expression - val cons: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val prefix: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val infix: - ?loc:loc -> ?attrs:attrs -> str -> expression -> expression -> expression - end - -(** Value declarations *) -module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:str list -> str -> core_type -> value_description - end - -(** Type declarations *) -module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * variance_and_injectivity) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> - str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - -(** Type extensions *) -module Te: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * variance_and_injectivity) list -> - ?priv:private_flag -> lid -> extension_constructor list -> type_extension - - val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - extension_constructor -> type_exception - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> - str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - -(** {1 Module language} *) - -(** Module type expressions *) -module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter with_loc list -> module_type -> module_type - val gen: ?loc:loc -> ?attrs:attrs -> loc -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - -(** Module expressions *) -module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter with_loc list -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> package_type option - -> package_type option -> module_expr - val apply_unit: ?loc:loc -> ?attrs:attrs -> module_expr -> loc -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - val hole: ?loc:loc -> ?attrs:attrs -> unit -> module_expr - end - -(** Signature items *) -module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_subst: ?loc:loc -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> type_exception -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val mod_subst: ?loc:loc -> module_substitution -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val modtype_subst: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - -(** Structure items *) -module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> value_bindings -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> type_exception -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_declaration -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - -(** Module declarations *) -module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> functor_parameter with_loc list -> module_type -> module_declaration - end - -(** Module substitutions *) -module Ms: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> lid -> module_substitution - end - -(** Module type declarations *) -module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - -(** Module bindings *) -module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> functor_parameter with_loc list -> module_expr -> module_binding - end - -(** Opens *) -module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> 'a -> 'a open_infos - end - -(** Includes *) -module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - -(** Value bindings *) -module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?value_constraint:value_constraint -> is_pun:bool -> pattern -> - expression -> value_binding - end - - -(** {1 Class language} *) - -(** Class type expressions *) -module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arrow_param list -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type - -> class_type - end - -(** Class type fields *) -module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_virtual -> - core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_virtual -> - core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - -(** Class expressions *) -module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> value_bindings -> class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr - -> class_expr - end - -(** Class fields *) -module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_virtual -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_virtual -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - -(** Classes *) -module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> - ?params:(core_type * variance_and_injectivity) list -> - str -> 'a -> 'a class_infos - end - -(** Class signatures *) -module Csig: - sig - val mk: core_type option -> class_type_field list -> class_signature - end - -(** Class structures *) -module Cstr: - sig - val mk: pattern option -> class_field list -> class_structure - end - -(** Row fields *) -module Rf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field - val tag: ?loc:loc -> ?attrs:attrs -> - variant_var -> bool -> core_type list -> row_field - val inherit_: ?loc:loc -> core_type -> row_field - end - -(** Object fields *) -module Of: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - object_field_desc -> object_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> core_type -> object_field - val inherit_: ?loc:loc -> core_type -> object_field - end diff --git a/vendor/parser-extended/ast_mapper.mli b/vendor/parser-extended/ast_mapper.mli deleted file mode 100644 index e868f07164..0000000000 --- a/vendor/parser-extended/ast_mapper.mli +++ /dev/null @@ -1,121 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** The interface of a -ppx rewriter - - A -ppx rewriter is a program that accepts a serialized abstract syntax - tree and outputs another, possibly modified, abstract syntax tree. - This module encapsulates the interface between the compiler and - the -ppx rewriters, handling such details as the serialization format, - forwarding of command-line flags, and storing state. - - {!mapper} enables AST rewriting using open recursion. - A typical mapper would be based on {!default_mapper}, a deep - identity mapper, and will fall back on it for handling the syntax it - does not modify. For example: - - {[ -open Asttypes -open Parsetree -open Ast_mapper - -let test_mapper argv = - { default_mapper with - expr = fun mapper expr -> - match expr with - | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) - | other -> default_mapper.expr mapper other; } - -let () = - register "ppx_test" test_mapper]} - - This -ppx rewriter, which replaces [[%test]] in expressions with - the constant [42], can be compiled using - [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - - *) - -open Parsetree - -(** {1 A generic Parsetree mapper} *) - -type mapper = { - arg_label: mapper -> Asttypes.arg_label -> Asttypes.arg_label; - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_bindings: mapper -> value_bindings -> value_bindings; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - directive_argument: mapper -> directive_argument -> directive_argument; - toplevel_directive: mapper -> toplevel_directive -> toplevel_directive; - toplevel_phrase: mapper -> toplevel_phrase -> toplevel_phrase; - repl_phrase: mapper -> repl_phrase -> repl_phrase; -} -(** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - -val default_mapper: mapper -(** A default mapper, which implements a "deep identity" mapping. *) diff --git a/vendor/parser-extended/docstrings.mli b/vendor/parser-extended/docstrings.mli deleted file mode 100644 index bf2508fdc4..0000000000 --- a/vendor/parser-extended/docstrings.mli +++ /dev/null @@ -1,223 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Leo White *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** Documentation comments - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -(** (Re)Initialise all docstring state *) -val init : unit -> unit - -(** Emit warnings for unattached and ambiguous docstrings *) -val warn_bad_docstrings : unit -> unit - -(** {2 Docstrings} *) - -(** Documentation comments *) -type docstring - -(** Create a docstring *) -val docstring : string -> Location.t -> docstring - -(** Register a docstring *) -val register : docstring -> unit - -(** Get the text of a docstring *) -val docstring_body : docstring -> string - -(** Get the location of a docstring *) -val docstring_loc : docstring -> Location.t - -(** {2 Set functions} - - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - -(** Docstrings immediately preceding a token *) -val set_pre_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following a token *) -val set_post_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings not immediately adjacent to a token *) -val set_floating_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following the token which precedes this one *) -val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately preceding the token which follows this one *) -val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - -(** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -val empty_docs : docs - -val docs_attr : docstring -> Parsetree.attribute - -(** Convert item documentation to attributes and add them to an - attribute list *) -val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : unit -> docs -val symbol_docs_lazy : unit -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : int -> int -> docs -val rhs_docs_lazy : int -> int -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : unit -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : int -> int -> unit - -(** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - -type info = docstring option - -val empty_info : info - -val info_attr : docstring -> Parsetree.attribute - -(** Convert field info to attributes and add them to an - attribute list *) -val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the field info for the current symbol. *) -val symbol_info : unit -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : int -> info - -(** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - -type text = docstring list - -val empty_text : text -val empty_text_lazy : text Lazy.t - -val text_attr : docstring -> Parsetree.attribute - -(** Convert text to attributes and add them to an attribute list *) -val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the text preceding the current symbol. *) -val symbol_text : unit -> text -val symbol_text_lazy : unit -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : int -> text -val rhs_text_lazy : int -> text Lazy.t - -(** {2 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : unit -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : unit -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : int -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : int -> text - -(** Fetch text following the symbol at the given position *) -val rhs_post_text : int -> text - -module WithMenhir: sig -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : Lexing.position * Lexing.position -> docs -val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : Lexing.position -> Lexing.position -> docs -val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : Lexing.position * Lexing.position -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : Lexing.position -> Lexing.position -> unit - -(** Fetch the field info for the current symbol. *) -val symbol_info : Lexing.position -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : Lexing.position -> info - -(** Fetch the text preceding the current symbol. *) -val symbol_text : Lexing.position -> text -val symbol_text_lazy : Lexing.position -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : Lexing.position -> text -val rhs_text_lazy : Lexing.position -> text Lazy.t - -(** {3 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : Lexing.position -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : Lexing.position -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : Lexing.position -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : Lexing.position -> text - -(** Fetch text following the symbol at the given position *) -val rhs_post_text : Lexing.position -> text - -end diff --git a/vendor/parser-extended/parse.mli b/vendor/parser-extended/parse.mli deleted file mode 100644 index 0de6b48a13..0000000000 --- a/vendor/parser-extended/parse.mli +++ /dev/null @@ -1,110 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** Entry points in the parser - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -val implementation : Lexing.lexbuf -> Parsetree.structure -val interface : Lexing.lexbuf -> Parsetree.signature -val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase -val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list -val core_type : Lexing.lexbuf -> Parsetree.core_type -val expression : Lexing.lexbuf -> Parsetree.expression -val pattern : Lexing.lexbuf -> Parsetree.pattern -val module_type : Lexing.lexbuf -> Parsetree.module_type -val module_expr : Lexing.lexbuf -> Parsetree.module_expr - -(** The functions below can be used to parse Longident safely. *) - -val longident: Lexing.lexbuf -> Longident.t -(** - The function [longident] is guaranteed to parse all subclasses - of {!Longident.t} used in OCaml: values, constructors, simple or extended - module paths, and types or module types. - - However, this function accepts inputs which are not accepted by the - compiler, because they combine functor applications and infix operators. - In valid OCaml syntax, only value-level identifiers may end with infix - operators [Foo.( + )]. - Moreover, in value-level identifiers the module path [Foo] must be simple - ([M.N] rather than [F(X)]): functor applications may only appear in - type-level identifiers. - As a consequence, a path such as [F(X).( + )] is not a valid OCaml - identifier; but it is accepted by this function. -*) - -(** The next functions are specialized to a subclass of {!Longident.t} *) - -val val_ident: Lexing.lexbuf -> Longident.t -(** - This function parses a syntactically valid path for a value. For instance, - [x], [M.x], and [(+.)] are valid. Contrarily, [M.A], [F(X).x], and [true] - are rejected. - - Longident for OCaml's value cannot contain functor application. - The last component of the {!Longident.t} is not capitalized, - but can be an operator [A.Path.To.(.%.%.(;..)<-)] -*) - -val constr_ident: Lexing.lexbuf -> Longident.t -(** - This function parses a syntactically valid path for a variant constructor. - For instance, [A], [M.A] and [M.(::)] are valid, but both [M.a] - and [F(X).A] are rejected. - - Longident for OCaml's variant constructors cannot contain functor - application. - The last component of the {!Longident.t} is capitalized, - or it may be one the special constructors: [true],[false],[()],[[]],[(::)]. - Among those special constructors, only [(::)] can be prefixed by a module - path ([A.B.C.(::)]). -*) - - -val simple_module_path: Lexing.lexbuf -> Longident.t -(** - This function parses a syntactically valid path for a module. - For instance, [A], and [M.A] are valid, but both [M.a] - and [F(X).A] are rejected. - - Longident for OCaml's module cannot contain functor application. - The last component of the {!Longident.t} is capitalized. -*) - - -val extended_module_path: Lexing.lexbuf -> Longident.t -(** - This function parse syntactically valid path for an extended module. - For instance, [A.B] and [F(A).B] are valid. Contrarily, - [(.%())] or [[]] are both rejected. - - The last component of the {!Longident.t} is capitalized. - -*) - -val type_ident: Lexing.lexbuf -> Longident.t -(** - This function parse syntactically valid path for a type or a module type. - For instance, [A], [t], [M.t] and [F(X).t] are valid. Contrarily, - [(.%())] or [[]] are both rejected. - - In path for type and module types, only operators and special constructors - are rejected. - -*) diff --git a/vendor/parser-extended/printast.mli b/vendor/parser-extended/printast.mli deleted file mode 100644 index 2f3fe19503..0000000000 --- a/vendor/parser-extended/printast.mli +++ /dev/null @@ -1,54 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Damien Doligez, projet Para, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** Raw printer for {!Parsetree} - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Parsetree -open Format - -val interface : formatter -> signature_item list -> unit -val implementation : formatter -> structure_item list -> unit -val top_phrase : formatter -> toplevel_phrase -> unit -val repl_phrase : formatter -> repl_phrase -> unit - -val expression: formatter -> expression -> unit -val structure: int -> formatter -> structure -> unit -val payload: formatter -> payload -> unit -val core_type: formatter -> core_type -> unit -val module_type: formatter -> module_type -> unit -val pattern: formatter -> pattern -> unit -val type_declaration: formatter -> type_declaration -> unit -val value_binding: formatter -> value_binding -> unit -val module_binding: formatter -> module_binding -> unit -val module_declaration: formatter -> module_declaration -> unit -val class_expr: formatter -> class_expr -> unit -val class_type: formatter -> class_type -> unit -val class_field: formatter -> class_field -> unit -val class_type_field: formatter -> class_type_field -> unit -val module_expr: formatter -> module_expr -> unit -val structure_item: formatter -> structure_item -> unit -val signature_item: formatter -> signature_item -> unit - -type cmts = - { before: Location.t -> string list option - ; within: Location.t -> string list option - ; after: Location.t -> string list option } - -val cmts : cmts option ref diff --git a/vendor/parser-standard/ast_helper.mli b/vendor/parser-standard/ast_helper.mli deleted file mode 100644 index 68e3396566..0000000000 --- a/vendor/parser-standard/ast_helper.mli +++ /dev/null @@ -1,499 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** Helpers to produce Parsetree fragments - - {b Warning} This module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Asttypes -open Docstrings -open Parsetree - -type 'a with_loc = 'a Location.loc -type loc = Location.t - -type lid = Longident.t with_loc -type str = string with_loc -type str_opt = string option with_loc -type attrs = attribute list - -(** {1 Default locations} *) - -val default_loc: loc ref - (** Default value for all optional location arguments. *) - -val with_default_loc: loc -> (unit -> 'a) -> 'a - (** Set the [default_loc] within the scope of the execution - of the provided function. *) - -(** {1 Constants} *) - -module Const : sig - val char : char -> constant - val string : - ?quotation_delimiter:string -> ?loc:Location.t -> string -> constant - val integer : ?suffix:char -> string -> constant - val int : ?suffix:char -> int -> constant - val int32 : ?suffix:char -> int32 -> constant - val int64 : ?suffix:char -> int64 -> constant - val nativeint : ?suffix:char -> nativeint -> constant - val float : ?suffix:char -> string -> constant -end - -(** {1 Attributes} *) -module Attr : sig - val mk: ?loc:loc -> str -> payload -> attribute -end - -(** {1 Core language} *) - -(** Type expressions *) -module Typ : - sig - val mk: ?loc:loc -> ?attrs:attrs -> core_type_desc -> core_type - val attr: core_type -> attribute -> core_type - - val any: ?loc:loc -> ?attrs:attrs -> unit -> core_type - val var: ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> core_type - -> core_type - val tuple: ?loc:loc -> ?attrs:attrs -> core_type list -> core_type - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val object_: ?loc:loc -> ?attrs:attrs -> object_field list - -> closed_flag -> core_type - val class_: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type - val alias: ?loc:loc -> ?attrs:attrs -> core_type -> string -> core_type - val variant: ?loc:loc -> ?attrs:attrs -> row_field list -> closed_flag - -> label list option -> core_type - val poly: ?loc:loc -> ?attrs:attrs -> str list -> core_type -> core_type - val package: ?loc:loc -> ?attrs:attrs -> lid -> (lid * core_type) list - -> core_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> core_type - - val force_poly: core_type -> core_type - - val varify_constructors: str list -> core_type -> core_type - (** [varify_constructors newtypes te] is type expression [te], of which - any of nullary type constructor [tc] is replaced by type variable of - the same name, if [tc]'s name appears in [newtypes]. - Raise [Syntaxerr.Variable_in_scope] if any type variable inside [te] - appears in [newtypes]. - @since 4.05 - *) - end - -(** Patterns *) -module Pat: - sig - val mk: ?loc:loc -> ?attrs:attrs -> pattern_desc -> pattern - val attr:pattern -> attribute -> pattern - - val any: ?loc:loc -> ?attrs:attrs -> unit -> pattern - val var: ?loc:loc -> ?attrs:attrs -> str -> pattern - val alias: ?loc:loc -> ?attrs:attrs -> pattern -> str -> pattern - val constant: ?loc:loc -> ?attrs:attrs -> constant -> pattern - val interval: ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern - val tuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct: ?loc:loc -> ?attrs:attrs -> - lid -> (str list * pattern) option -> pattern - val variant: ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern - val record: ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag - -> pattern - val array: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val or_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern - val constraint_: ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern - val type_: ?loc:loc -> ?attrs:attrs -> lid -> pattern - val lazy_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val unpack: ?loc:loc -> ?attrs:attrs -> str_opt -> pattern - val open_: ?loc:loc -> ?attrs:attrs -> lid -> pattern -> pattern - val exception_: ?loc:loc -> ?attrs:attrs -> pattern -> pattern - val extension: ?loc:loc -> ?attrs:attrs -> extension -> pattern - end - -(** Expressions *) -module Exp: - sig - val mk: ?loc:loc -> ?attrs:attrs -> expression_desc -> expression - val attr: expression -> attribute -> expression - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> expression - val constant: ?loc:loc -> ?attrs:attrs -> constant -> expression - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list - -> expression -> expression - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option - -> pattern -> expression -> expression - val function_: ?loc:loc -> ?attrs:attrs -> case list -> expression - val apply: ?loc:loc -> ?attrs:attrs -> expression - -> (arg_label * expression) list -> expression - val match_: ?loc:loc -> ?attrs:attrs -> expression -> case list - -> expression - val try_: ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression - val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val construct: ?loc:loc -> ?attrs:attrs -> lid -> expression option - -> expression - val variant: ?loc:loc -> ?attrs:attrs -> label -> expression option - -> expression - val record: ?loc:loc -> ?attrs:attrs -> (lid * expression) list - -> expression option -> expression - val field: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - val setfield: ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression - -> expression - val array: ?loc:loc -> ?attrs:attrs -> expression list -> expression - val ifthenelse: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression option -> expression - val sequence: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val while_: ?loc:loc -> ?attrs:attrs -> expression -> expression - -> expression - val for_: ?loc:loc -> ?attrs:attrs -> pattern -> expression -> expression - -> direction_flag -> expression -> expression - val coerce: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> core_type -> expression - val constraint_: ?loc:loc -> ?attrs:attrs -> expression -> core_type - -> expression - val send: ?loc:loc -> ?attrs:attrs -> expression -> str -> expression - val new_: ?loc:loc -> ?attrs:attrs -> lid -> expression - val setinstvar: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val override: ?loc:loc -> ?attrs:attrs -> (str * expression) list - -> expression - val letmodule: ?loc:loc -> ?attrs:attrs -> str_opt -> module_expr - -> expression -> expression - val letexception: - ?loc:loc -> ?attrs:attrs -> extension_constructor -> expression - -> expression - val assert_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val lazy_: ?loc:loc -> ?attrs:attrs -> expression -> expression - val poly: ?loc:loc -> ?attrs:attrs -> expression -> core_type option - -> expression - val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression - val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression - val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> open_declaration -> expression - -> expression - val letop: ?loc:loc -> ?attrs:attrs -> binding_op - -> binding_op list -> expression -> expression - val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression - val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression - - val case: pattern -> ?guard:expression -> expression -> case - val binding_op: str -> pattern -> expression -> loc -> binding_op - val hole: ?loc:loc -> ?attrs:attrs -> unit -> expression - end - -(** Value declarations *) -module Val: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?prim:string list -> str -> core_type -> value_description - end - -(** Type declarations *) -module Type: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?params:(core_type * (variance * injectivity)) list -> - ?cstrs:(core_type * core_type * loc) list -> - ?kind:type_kind -> ?priv:private_flag -> ?manifest:core_type -> str -> - type_declaration - - val constructor: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> - str -> - constructor_declaration - val field: ?loc:loc -> ?attrs:attrs -> ?info:info -> - ?mut:mutable_flag -> str -> core_type -> label_declaration - end - -(** Type extensions *) -module Te: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - ?params:(core_type * (variance * injectivity)) list -> - ?priv:private_flag -> lid -> extension_constructor list -> type_extension - - val mk_exception: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - extension_constructor -> type_exception - - val constructor: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> extension_constructor_kind -> extension_constructor - - val decl: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - ?vars:str list -> ?args:constructor_arguments -> ?res:core_type -> - str -> - extension_constructor - val rebind: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?info:info -> - str -> lid -> extension_constructor - end - -(** {1 Module language} *) - -(** Module type expressions *) -module Mty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_type_desc -> module_type - val attr: module_type -> attribute -> module_type - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val alias: ?loc:loc -> ?attrs:attrs -> lid -> module_type - val signature: ?loc:loc -> ?attrs:attrs -> signature -> module_type - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_type -> module_type - val with_: ?loc:loc -> ?attrs:attrs -> module_type -> - with_constraint list -> module_type - val typeof_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_type - end - -(** Module expressions *) -module Mod: - sig - val mk: ?loc:loc -> ?attrs:attrs -> module_expr_desc -> module_expr - val attr: module_expr -> attribute -> module_expr - - val ident: ?loc:loc -> ?attrs:attrs -> lid -> module_expr - val structure: ?loc:loc -> ?attrs:attrs -> structure -> module_expr - val functor_: ?loc:loc -> ?attrs:attrs -> - functor_parameter -> module_expr -> module_expr - val apply: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr -> - module_expr - val apply_unit: ?loc:loc -> ?attrs:attrs -> module_expr -> module_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> module_expr -> module_type -> - module_expr - val unpack: ?loc:loc -> ?attrs:attrs -> expression -> module_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> module_expr - val hole: ?loc:loc -> ?attrs:attrs -> unit -> module_expr - end - -(** Signature items *) -module Sig: - sig - val mk: ?loc:loc -> signature_item_desc -> signature_item - - val value: ?loc:loc -> value_description -> signature_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> signature_item - val type_subst: ?loc:loc -> type_declaration list -> signature_item - val type_extension: ?loc:loc -> type_extension -> signature_item - val exception_: ?loc:loc -> type_exception -> signature_item - val module_: ?loc:loc -> module_declaration -> signature_item - val mod_subst: ?loc:loc -> module_substitution -> signature_item - val rec_module: ?loc:loc -> module_declaration list -> signature_item - val modtype: ?loc:loc -> module_type_declaration -> signature_item - val modtype_subst: ?loc:loc -> module_type_declaration -> signature_item - val open_: ?loc:loc -> open_description -> signature_item - val include_: ?loc:loc -> include_description -> signature_item - val class_: ?loc:loc -> class_description list -> signature_item - val class_type: ?loc:loc -> class_type_declaration list -> signature_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> signature_item - val attribute: ?loc:loc -> attribute -> signature_item - val text: text -> signature_item list - end - -(** Structure items *) -module Str: - sig - val mk: ?loc:loc -> structure_item_desc -> structure_item - - val eval: ?loc:loc -> ?attrs:attributes -> expression -> structure_item - val value: ?loc:loc -> rec_flag -> value_binding list -> structure_item - val primitive: ?loc:loc -> value_description -> structure_item - val type_: ?loc:loc -> rec_flag -> type_declaration list -> structure_item - val type_extension: ?loc:loc -> type_extension -> structure_item - val exception_: ?loc:loc -> type_exception -> structure_item - val module_: ?loc:loc -> module_binding -> structure_item - val rec_module: ?loc:loc -> module_binding list -> structure_item - val modtype: ?loc:loc -> module_type_declaration -> structure_item - val open_: ?loc:loc -> open_declaration -> structure_item - val class_: ?loc:loc -> class_declaration list -> structure_item - val class_type: ?loc:loc -> class_type_declaration list -> structure_item - val include_: ?loc:loc -> include_declaration -> structure_item - val extension: ?loc:loc -> ?attrs:attrs -> extension -> structure_item - val attribute: ?loc:loc -> attribute -> structure_item - val text: text -> structure_item list - end - -(** Module declarations *) -module Md: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_type -> module_declaration - end - -(** Module substitutions *) -module Ms: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str -> lid -> module_substitution - end - -(** Module type declarations *) -module Mtd: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?typ:module_type -> str -> module_type_declaration - end - -(** Module bindings *) -module Mb: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - str_opt -> module_expr -> module_binding - end - -(** Opens *) -module Opn: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> 'a -> 'a open_infos - end - -(** Includes *) -module Incl: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> 'a -> 'a include_infos - end - -(** Value bindings *) -module Vb: - sig - val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?value_constraint:value_constraint -> pattern -> expression -> - value_binding - end - - -(** {1 Class language} *) - -(** Class type expressions *) -module Cty: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_type_desc -> class_type - val attr: class_type -> attribute -> class_type - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_type - val signature: ?loc:loc -> ?attrs:attrs -> class_signature -> class_type - val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> - class_type -> class_type - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_type - -> class_type - end - -(** Class type fields *) -module Ctf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> - class_type_field_desc -> class_type_field - val attr: class_type_field -> attribute -> class_type_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> class_type -> class_type_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - virtual_flag -> core_type -> class_type_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - virtual_flag -> core_type -> class_type_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_type_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type_field - val attribute: ?loc:loc -> attribute -> class_type_field - val text: text -> class_type_field list - end - -(** Class expressions *) -module Cl: - sig - val mk: ?loc:loc -> ?attrs:attrs -> class_expr_desc -> class_expr - val attr: class_expr -> attribute -> class_expr - - val constr: ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> class_expr - val structure: ?loc:loc -> ?attrs:attrs -> class_structure -> class_expr - val fun_: ?loc:loc -> ?attrs:attrs -> arg_label -> expression option -> - pattern -> class_expr -> class_expr - val apply: ?loc:loc -> ?attrs:attrs -> class_expr -> - (arg_label * expression) list -> class_expr - val let_: ?loc:loc -> ?attrs:attrs -> rec_flag -> value_binding list -> - class_expr -> class_expr - val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> - class_expr - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> open_description -> class_expr - -> class_expr - end - -(** Class fields *) -module Cf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> class_field_desc -> - class_field - val attr: class_field -> attribute -> class_field - - val inherit_: ?loc:loc -> ?attrs:attrs -> override_flag -> class_expr -> - str option -> class_field - val val_: ?loc:loc -> ?attrs:attrs -> str -> mutable_flag -> - class_field_kind -> class_field - val method_: ?loc:loc -> ?attrs:attrs -> str -> private_flag -> - class_field_kind -> class_field - val constraint_: ?loc:loc -> ?attrs:attrs -> core_type -> core_type -> - class_field - val initializer_: ?loc:loc -> ?attrs:attrs -> expression -> class_field - val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_field - val attribute: ?loc:loc -> attribute -> class_field - val text: text -> class_field list - - val virtual_: core_type -> class_field_kind - val concrete: override_flag -> expression -> class_field_kind - - end - -(** Classes *) -module Ci: - sig - val mk: ?loc:loc -> ?attrs:attrs -> ?docs:docs -> ?text:text -> - ?virt:virtual_flag -> - ?params:(core_type * (variance * injectivity)) list -> - str -> 'a -> 'a class_infos - end - -(** Class signatures *) -module Csig: - sig - val mk: core_type -> class_type_field list -> class_signature - end - -(** Class structures *) -module Cstr: - sig - val mk: pattern -> class_field list -> class_structure - end - -(** Row fields *) -module Rf: - sig - val mk: ?loc:loc -> ?attrs:attrs -> row_field_desc -> row_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> bool -> core_type list -> row_field - val inherit_: ?loc:loc -> core_type -> row_field - end - -(** Object fields *) -module Of: - sig - val mk: ?loc:loc -> ?attrs:attrs -> - object_field_desc -> object_field - val tag: ?loc:loc -> ?attrs:attrs -> - label with_loc -> core_type -> object_field - val inherit_: ?loc:loc -> core_type -> object_field - end diff --git a/vendor/parser-standard/ast_mapper.ml b/vendor/parser-standard/ast_mapper.ml index 7b399f07b1..ee6abb0b87 100644 --- a/vendor/parser-standard/ast_mapper.ml +++ b/vendor/parser-standard/ast_mapper.ml @@ -1099,6 +1099,7 @@ let add_ppx_context_sig ~tool_name ast = let apply ~source ~target mapper = apply_lazy ~source ~target (fun () -> mapper) +(* let run_main mapper = try let a = Sys.argv in @@ -1123,3 +1124,4 @@ let run_main mapper = let register_function = ref (fun _name f -> run_main f) let register name f = !register_function name f +*) diff --git a/vendor/parser-standard/ast_mapper.mli b/vendor/parser-standard/ast_mapper.mli deleted file mode 100644 index ecd4fd6b02..0000000000 --- a/vendor/parser-standard/ast_mapper.mli +++ /dev/null @@ -1,211 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Alain Frisch, LexiFi *) -(* *) -(* Copyright 2012 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** The interface of a -ppx rewriter - - A -ppx rewriter is a program that accepts a serialized abstract syntax - tree and outputs another, possibly modified, abstract syntax tree. - This module encapsulates the interface between the compiler and - the -ppx rewriters, handling such details as the serialization format, - forwarding of command-line flags, and storing state. - - {!mapper} enables AST rewriting using open recursion. - A typical mapper would be based on {!default_mapper}, a deep - identity mapper, and will fall back on it for handling the syntax it - does not modify. For example: - - {[ -open Asttypes -open Parsetree -open Ast_mapper - -let test_mapper argv = - { default_mapper with - expr = fun mapper expr -> - match expr with - | { pexp_desc = Pexp_extension ({ txt = "test" }, PStr [])} -> - Ast_helper.Exp.constant (Const_int 42) - | other -> default_mapper.expr mapper other; } - -let () = - register "ppx_test" test_mapper]} - - This -ppx rewriter, which replaces [[%test]] in expressions with - the constant [42], can be compiled using - [ocamlc -o ppx_test -I +compiler-libs ocamlcommon.cma ppx_test.ml]. - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - - *) - -open Parsetree - -(** {1 A generic Parsetree mapper} *) - -type mapper = { - attribute: mapper -> attribute -> attribute; - attributes: mapper -> attribute list -> attribute list; - binding_op: mapper -> binding_op -> binding_op; - case: mapper -> case -> case; - cases: mapper -> case list -> case list; - class_declaration: mapper -> class_declaration -> class_declaration; - class_description: mapper -> class_description -> class_description; - class_expr: mapper -> class_expr -> class_expr; - class_field: mapper -> class_field -> class_field; - class_signature: mapper -> class_signature -> class_signature; - class_structure: mapper -> class_structure -> class_structure; - class_type: mapper -> class_type -> class_type; - class_type_declaration: mapper -> class_type_declaration - -> class_type_declaration; - class_type_field: mapper -> class_type_field -> class_type_field; - constant: mapper -> constant -> constant; - constructor_declaration: mapper -> constructor_declaration - -> constructor_declaration; - expr: mapper -> expression -> expression; - extension: mapper -> extension -> extension; - extension_constructor: mapper -> extension_constructor - -> extension_constructor; - include_declaration: mapper -> include_declaration -> include_declaration; - include_description: mapper -> include_description -> include_description; - label_declaration: mapper -> label_declaration -> label_declaration; - location: mapper -> Location.t -> Location.t; - module_binding: mapper -> module_binding -> module_binding; - module_declaration: mapper -> module_declaration -> module_declaration; - module_substitution: mapper -> module_substitution -> module_substitution; - module_expr: mapper -> module_expr -> module_expr; - module_type: mapper -> module_type -> module_type; - module_type_declaration: mapper -> module_type_declaration - -> module_type_declaration; - open_declaration: mapper -> open_declaration -> open_declaration; - open_description: mapper -> open_description -> open_description; - pat: mapper -> pattern -> pattern; - payload: mapper -> payload -> payload; - signature: mapper -> signature -> signature; - signature_item: mapper -> signature_item -> signature_item; - structure: mapper -> structure -> structure; - structure_item: mapper -> structure_item -> structure_item; - typ: mapper -> core_type -> core_type; - type_declaration: mapper -> type_declaration -> type_declaration; - type_extension: mapper -> type_extension -> type_extension; - type_exception: mapper -> type_exception -> type_exception; - type_kind: mapper -> type_kind -> type_kind; - value_binding: mapper -> value_binding -> value_binding; - value_description: mapper -> value_description -> value_description; - with_constraint: mapper -> with_constraint -> with_constraint; - directive_argument: mapper -> directive_argument -> directive_argument; - toplevel_directive: mapper -> toplevel_directive -> toplevel_directive; - toplevel_phrase: mapper -> toplevel_phrase -> toplevel_phrase; -} -(** A mapper record implements one "method" per syntactic category, - using an open recursion style: each method takes as its first - argument the mapper to be applied to children in the syntax - tree. *) - -val default_mapper: mapper -(** A default mapper, which implements a "deep identity" mapping. *) - -(** {1 Apply mappers to compilation units} *) - -val tool_name: unit -> string -(** Can be used within a ppx preprocessor to know which tool is - calling it ["ocamlc"], ["ocamlopt"], ["ocamldoc"], ["ocamldep"], - ["ocaml"], ... Some global variables that reflect command-line - options are automatically synchronized between the calling tool - and the ppx preprocessor: {!Clflags.include_dirs}, - {!Load_path}, {!Clflags.open_modules}, {!Clflags.for_package}, - {!Clflags.debug}. *) - - -val apply: source:string -> target:string -> mapper -> unit -(** Apply a mapper (parametrized by the unit name) to a dumped - parsetree found in the [source] file and put the result in the - [target] file. The [structure] or [signature] field of the mapper - is applied to the implementation or interface. *) - -val run_main: (string list -> mapper) -> unit -(** Entry point to call to implement a standalone -ppx rewriter from a - mapper, parametrized by the command line arguments. The current - unit name can be obtained from {!Location.input_name}. This - function implements proper error reporting for uncaught - exceptions. *) - -(** {1 Registration API} *) - -val register_function: (string -> (string list -> mapper) -> unit) ref - -val register: string -> (string list -> mapper) -> unit -(** Apply the [register_function]. The default behavior is to run the - mapper immediately, taking arguments from the process command - line. This is to support a scenario where a mapper is linked as a - stand-alone executable. - - It is possible to overwrite the [register_function] to define - "-ppx drivers", which combine several mappers in a single process. - Typically, a driver starts by defining [register_function] to a - custom implementation, then lets ppx rewriters (linked statically - or dynamically) register themselves, and then run all or some of - them. It is also possible to have -ppx drivers apply rewriters to - only specific parts of an AST. - - The first argument to [register] is a symbolic name to be used by - the ppx driver. *) - - -(** {1 Convenience functions to write mappers} *) - -val map_opt: ('a -> 'b) -> 'a option -> 'b option - -val extension_of_error: Location.error -> extension -(** Encode an error into an 'ocaml.error' extension node which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the error. *) - -val attribute_of_warning: Location.t -> string -> attribute -(** Encode a warning message into an 'ocaml.ppwarning' attribute which can be - inserted in a generated Parsetree. The compiler will be - responsible for reporting the warning. *) - -(** {1 Helper functions to call external mappers} *) - -val add_ppx_context_str: - tool_name:string -> Parsetree.structure -> Parsetree.structure -(** Extract information from the current environment and encode it - into an attribute which is prepended to the list of structure - items in order to pass the information to an external - processor. *) - -val add_ppx_context_sig: - tool_name:string -> Parsetree.signature -> Parsetree.signature -(** Same as [add_ppx_context_str], but for signatures. *) - -val drop_ppx_context_str: - restore:bool -> Parsetree.structure -> Parsetree.structure -(** Drop the ocaml.ppx.context attribute from a structure. If - [restore] is true, also restore the associated data in the current - process. *) - -val drop_ppx_context_sig: - restore:bool -> Parsetree.signature -> Parsetree.signature -(** Same as [drop_ppx_context_str], but for signatures. *) - -(** {1 Cookies} *) - -(** Cookies are used to pass information from a ppx processor to - a further invocation of itself, when called from the OCaml - toplevel (or other tools that support cookies). *) - -val set_cookie: string -> Parsetree.expression -> unit -val get_cookie: string -> Parsetree.expression option diff --git a/vendor/parser-standard/docstrings.mli b/vendor/parser-standard/docstrings.mli deleted file mode 100644 index bf2508fdc4..0000000000 --- a/vendor/parser-standard/docstrings.mli +++ /dev/null @@ -1,223 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Leo White *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** Documentation comments - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -(** (Re)Initialise all docstring state *) -val init : unit -> unit - -(** Emit warnings for unattached and ambiguous docstrings *) -val warn_bad_docstrings : unit -> unit - -(** {2 Docstrings} *) - -(** Documentation comments *) -type docstring - -(** Create a docstring *) -val docstring : string -> Location.t -> docstring - -(** Register a docstring *) -val register : docstring -> unit - -(** Get the text of a docstring *) -val docstring_body : docstring -> string - -(** Get the location of a docstring *) -val docstring_loc : docstring -> Location.t - -(** {2 Set functions} - - These functions are used by the lexer to associate docstrings to - the locations of tokens. *) - -(** Docstrings immediately preceding a token *) -val set_pre_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following a token *) -val set_post_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings not immediately adjacent to a token *) -val set_floating_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately following the token which precedes this one *) -val set_pre_extra_docstrings : Lexing.position -> docstring list -> unit - -(** Docstrings immediately preceding the token which follows this one *) -val set_post_extra_docstrings : Lexing.position -> docstring list -> unit - -(** {2 Items} - - The {!docs} type represents documentation attached to an item. *) - -type docs = - { docs_pre: docstring option; - docs_post: docstring option; } - -val empty_docs : docs - -val docs_attr : docstring -> Parsetree.attribute - -(** Convert item documentation to attributes and add them to an - attribute list *) -val add_docs_attrs : docs -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : unit -> docs -val symbol_docs_lazy : unit -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : int -> int -> docs -val rhs_docs_lazy : int -> int -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : unit -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : int -> int -> unit - -(** {2 Fields and constructors} - - The {!info} type represents documentation attached to a field or - constructor. *) - -type info = docstring option - -val empty_info : info - -val info_attr : docstring -> Parsetree.attribute - -(** Convert field info to attributes and add them to an - attribute list *) -val add_info_attrs : info -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the field info for the current symbol. *) -val symbol_info : unit -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : int -> info - -(** {2 Unattached comments} - - The {!text} type represents documentation which is not attached to - anything. *) - -type text = docstring list - -val empty_text : text -val empty_text_lazy : text Lazy.t - -val text_attr : docstring -> Parsetree.attribute - -(** Convert text to attributes and add them to an attribute list *) -val add_text_attrs : text -> Parsetree.attributes -> Parsetree.attributes - -(** Fetch the text preceding the current symbol. *) -val symbol_text : unit -> text -val symbol_text_lazy : unit -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : int -> text -val rhs_text_lazy : int -> text Lazy.t - -(** {2 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : unit -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : unit -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : int -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : int -> text - -(** Fetch text following the symbol at the given position *) -val rhs_post_text : int -> text - -module WithMenhir: sig -(** Fetch the item documentation for the current symbol. This also - marks this documentation (for ambiguity warnings). *) -val symbol_docs : Lexing.position * Lexing.position -> docs -val symbol_docs_lazy : Lexing.position * Lexing.position -> docs Lazy.t - -(** Fetch the item documentation for the symbols between two - positions. This also marks this documentation (for ambiguity - warnings). *) -val rhs_docs : Lexing.position -> Lexing.position -> docs -val rhs_docs_lazy : Lexing.position -> Lexing.position -> docs Lazy.t - -(** Mark the item documentation for the current symbol (for ambiguity - warnings). *) -val mark_symbol_docs : Lexing.position * Lexing.position -> unit - -(** Mark as associated the item documentation for the symbols between - two positions (for ambiguity warnings) *) -val mark_rhs_docs : Lexing.position -> Lexing.position -> unit - -(** Fetch the field info for the current symbol. *) -val symbol_info : Lexing.position -> info - -(** Fetch the field info following the symbol at a given position. *) -val rhs_info : Lexing.position -> info - -(** Fetch the text preceding the current symbol. *) -val symbol_text : Lexing.position -> text -val symbol_text_lazy : Lexing.position -> text Lazy.t - -(** Fetch the text preceding the symbol at the given position. *) -val rhs_text : Lexing.position -> text -val rhs_text_lazy : Lexing.position -> text Lazy.t - -(** {3 Extra text} - - There may be additional text attached to the delimiters of a block - (e.g. [struct] and [end]). This is fetched by the following - functions, which are applied to the contents of the block rather - than the delimiters. *) - -(** Fetch additional text preceding the current symbol *) -val symbol_pre_extra_text : Lexing.position -> text - -(** Fetch additional text following the current symbol *) -val symbol_post_extra_text : Lexing.position -> text - -(** Fetch additional text preceding the symbol at the given position *) -val rhs_pre_extra_text : Lexing.position -> text - -(** Fetch additional text following the symbol at the given position *) -val rhs_post_extra_text : Lexing.position -> text - -(** Fetch text following the symbol at the given position *) -val rhs_post_text : Lexing.position -> text - -end diff --git a/vendor/parser-standard/parse.mli b/vendor/parser-standard/parse.mli deleted file mode 100644 index 0de6b48a13..0000000000 --- a/vendor/parser-standard/parse.mli +++ /dev/null @@ -1,110 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** Entry points in the parser - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -val implementation : Lexing.lexbuf -> Parsetree.structure -val interface : Lexing.lexbuf -> Parsetree.signature -val toplevel_phrase : Lexing.lexbuf -> Parsetree.toplevel_phrase -val use_file : Lexing.lexbuf -> Parsetree.toplevel_phrase list -val core_type : Lexing.lexbuf -> Parsetree.core_type -val expression : Lexing.lexbuf -> Parsetree.expression -val pattern : Lexing.lexbuf -> Parsetree.pattern -val module_type : Lexing.lexbuf -> Parsetree.module_type -val module_expr : Lexing.lexbuf -> Parsetree.module_expr - -(** The functions below can be used to parse Longident safely. *) - -val longident: Lexing.lexbuf -> Longident.t -(** - The function [longident] is guaranteed to parse all subclasses - of {!Longident.t} used in OCaml: values, constructors, simple or extended - module paths, and types or module types. - - However, this function accepts inputs which are not accepted by the - compiler, because they combine functor applications and infix operators. - In valid OCaml syntax, only value-level identifiers may end with infix - operators [Foo.( + )]. - Moreover, in value-level identifiers the module path [Foo] must be simple - ([M.N] rather than [F(X)]): functor applications may only appear in - type-level identifiers. - As a consequence, a path such as [F(X).( + )] is not a valid OCaml - identifier; but it is accepted by this function. -*) - -(** The next functions are specialized to a subclass of {!Longident.t} *) - -val val_ident: Lexing.lexbuf -> Longident.t -(** - This function parses a syntactically valid path for a value. For instance, - [x], [M.x], and [(+.)] are valid. Contrarily, [M.A], [F(X).x], and [true] - are rejected. - - Longident for OCaml's value cannot contain functor application. - The last component of the {!Longident.t} is not capitalized, - but can be an operator [A.Path.To.(.%.%.(;..)<-)] -*) - -val constr_ident: Lexing.lexbuf -> Longident.t -(** - This function parses a syntactically valid path for a variant constructor. - For instance, [A], [M.A] and [M.(::)] are valid, but both [M.a] - and [F(X).A] are rejected. - - Longident for OCaml's variant constructors cannot contain functor - application. - The last component of the {!Longident.t} is capitalized, - or it may be one the special constructors: [true],[false],[()],[[]],[(::)]. - Among those special constructors, only [(::)] can be prefixed by a module - path ([A.B.C.(::)]). -*) - - -val simple_module_path: Lexing.lexbuf -> Longident.t -(** - This function parses a syntactically valid path for a module. - For instance, [A], and [M.A] are valid, but both [M.a] - and [F(X).A] are rejected. - - Longident for OCaml's module cannot contain functor application. - The last component of the {!Longident.t} is capitalized. -*) - - -val extended_module_path: Lexing.lexbuf -> Longident.t -(** - This function parse syntactically valid path for an extended module. - For instance, [A.B] and [F(A).B] are valid. Contrarily, - [(.%())] or [[]] are both rejected. - - The last component of the {!Longident.t} is capitalized. - -*) - -val type_ident: Lexing.lexbuf -> Longident.t -(** - This function parse syntactically valid path for a type or a module type. - For instance, [A], [t], [M.t] and [F(X).t] are valid. Contrarily, - [(.%())] or [[]] are both rejected. - - In path for type and module types, only operators and special constructors - are rejected. - -*) diff --git a/vendor/parser-standard/printast.mli b/vendor/parser-standard/printast.mli deleted file mode 100644 index f740e5cd88..0000000000 --- a/vendor/parser-standard/printast.mli +++ /dev/null @@ -1,34 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Damien Doligez, projet Para, INRIA Rocquencourt *) -(* *) -(* Copyright 1999 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* 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. *) -(* *) -(**************************************************************************) - -(** Raw printer for {!Parsetree} - - {b Warning:} this module is unstable and part of - {{!Compiler_libs}compiler-libs}. - -*) - -open Parsetree -open Format - -val interface : formatter -> signature_item list -> unit -val implementation : formatter -> structure_item list -> unit -val top_phrase : formatter -> toplevel_phrase -> unit - -val expression: int -> formatter -> expression -> unit -val structure: int -> formatter -> structure -> unit -val payload: int -> formatter -> payload -> unit -val core_type: int -> formatter -> core_type -> unit -val module_type: int -> formatter -> module_type -> unit From 271ca209a5013853179b3d3fcc11b02a993c7e69 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Wed, 20 Sep 2023 17:20:03 +0100 Subject: [PATCH 04/19] Sanitize result types (#2444) --- dune | 2 +- dune-project | 1 - lib/Fmt_odoc.ml | 3 +- lib/Fmt_odoc.mli | 3 +- lib/Translation_unit.ml | 21 ++++++------- lib/bin_conf/Bin_conf.ml | 30 +++++++++++-------- lib/bin_conf/dune | 8 +---- lib/dune | 5 +--- ocamlformat-lib.opam | 1 - vendor/ocamlformat-result/dune | 3 -- .../ocamlformat-result/ocamlformat_result.ml | 11 ------- .../ocamlformat-result/ocamlformat_result.mli | 11 ------- vendor/odoc-parser/dune | 2 +- 13 files changed, 36 insertions(+), 65 deletions(-) delete mode 100644 vendor/ocamlformat-result/dune delete mode 100644 vendor/ocamlformat-result/ocamlformat_result.ml delete mode 100644 vendor/ocamlformat-result/ocamlformat_result.mli diff --git a/dune b/dune index f5a217b435..a30a8353e4 100644 --- a/dune +++ b/dune @@ -19,7 +19,7 @@ (rule (with-stdout-to dune-project.formatted - (run dune format-dune-file dune-project))) + (run dune format-dune-file %{dep:dune-project}))) (rule (alias fmt) diff --git a/dune-project b/dune-project index ab06ced749..a3ee81c21d 100644 --- a/dune-project +++ b/dune-project @@ -82,7 +82,6 @@ (>= 1.4.0)) ; for vendored odoc-parser astring - result camlp-streams)) (package diff --git a/lib/Fmt_odoc.ml b/lib/Fmt_odoc.ml index 44b06d0d92..79930b5d34 100644 --- a/lib/Fmt_odoc.ml +++ b/lib/Fmt_odoc.ml @@ -13,7 +13,8 @@ open Fmt open Odoc_parser.Ast module Loc = Odoc_parser.Loc -type fmt_code = Conf.t -> offset:int -> string -> string or_error +type fmt_code = + Conf.t -> offset:int -> string -> (string, [`Msg of string]) Result.t type c = {fmt_code: fmt_code; conf: Conf.t} diff --git a/lib/Fmt_odoc.mli b/lib/Fmt_odoc.mli index 8b0aff5ea4..a5001e0cfc 100644 --- a/lib/Fmt_odoc.mli +++ b/lib/Fmt_odoc.mli @@ -11,7 +11,8 @@ (** [offset] is the column at which the content of the comment begins. It is used to adjust the margin. *) -type fmt_code = Conf.t -> offset:int -> string -> string or_error +type fmt_code = + Conf.t -> offset:int -> string -> (string, [`Msg of string]) Result.t val fmt_ast : Conf.t -> fmt_code:fmt_code -> Odoc_parser.Ast.t -> Fmt.t diff --git a/lib/Translation_unit.ml b/lib/Translation_unit.ml index cc7281e4bf..2013919c74 100644 --- a/lib/Translation_unit.ml +++ b/lib/Translation_unit.ml @@ -14,6 +14,10 @@ module Location = Migrate_ast.Location open Parse_with_comments +let ( let* ) = Result.( >>= ) + +let ( let+ ) = Result.( >>| ) + exception Internal_error of [ `Cannot_parse of exn @@ -217,16 +221,13 @@ let check_remaining_comments cmts = | cmts -> Error (List.map cmts ~f:dropped) let check_comments (conf : Conf.t) cmts ~old:t_old ~new_:t_new = - let open Result in if conf.opr_opts.comment_check.v then let errors = - check_remaining_comments cmts - >>= fun () -> + let* () = check_remaining_comments cmts in let split_cmts = List.partition_map ~f:(Cmts.is_docstring conf) in let old_docs, old_cmts = split_cmts t_old.comments in let new_docs, new_cmts = split_cmts t_new.comments in - Normalize_extended_ast.diff_cmts conf old_cmts new_cmts - >>= fun () -> + let* () = Normalize_extended_ast.diff_cmts conf old_cmts new_cmts in Normalize_extended_ast.diff_docstrings conf old_docs new_docs in match errors with @@ -300,7 +301,7 @@ let format (type a b) (fg : a Extended_ast.t) (std_fg : b Std_ast.t) |> List.filter_map ~f:(fun (s, f_opt) -> Option.map f_opt ~f:(fun f -> (s, String.sexp_of_t f)) ) in - let+ t_new = + let* t_new = match parse (parse_ast conf) ~disable_w50:true fg conf ~input_name ~source:fmted @@ -309,7 +310,7 @@ let format (type a b) (fg : a Extended_ast.t) (std_fg : b Std_ast.t) | exception exn -> internal_error [`Cannot_parse exn] (exn_args ()) | t_new -> Ok t_new in - let+ std_t_new = + let* std_t_new = match parse Std_ast.Parse.ast std_fg conf ~input_name ~source:fmted with @@ -391,18 +392,18 @@ let parse_and_format (type a b) (fg : a Extended_ast.t) (std_fg : b Std_ast.t) ?output_file ~input_name ~source (conf : Conf.t) = Location.input_name := input_name ; let line_endings = conf.fmt_opts.line_endings.v in - let+ parsed = + let* parsed = parse_result (parse_ast conf) ~disable_w50:true fg conf ~source ~input_name in - let+ std_parsed = + let* std_parsed = parse_result Std_ast.Parse.ast std_fg conf ~source ~input_name in let+ strlocs, formatted = format fg std_fg ?output_file ~input_name ~prev_source:source ~parsed ~std_parsed conf in - Ok (Eol_compat.normalize_eol ~exclude_locs:strlocs ~line_endings formatted) + Eol_compat.normalize_eol ~exclude_locs:strlocs ~line_endings formatted let parse_and_format syntax = let (Extended_ast.Any ext) = Extended_ast.of_syntax syntax in diff --git a/lib/bin_conf/Bin_conf.ml b/lib/bin_conf/Bin_conf.ml index fd832322c9..05280bf891 100644 --- a/lib/bin_conf/Bin_conf.ml +++ b/lib/bin_conf/Bin_conf.ml @@ -615,6 +615,10 @@ type action = | Check of input list | Print_config of Conf.t +let ( let* ) = Result.( >>= ) + +let ( let+ ) = Result.( >>| ) + let make_action ~enable_outside_detected_project ~root action inputs = let make_file ?name kind file = let name = Option.value ~default:file name in @@ -622,14 +626,14 @@ let make_action ~enable_outside_detected_project ~root action inputs = build_config ~enable_outside_detected_project ~root ~file:name ~is_stdin:false in - Ok {kind; name; file= File file; conf} + {kind; name; file= File file; conf} in let make_stdin ?(name = "") kind = let+ conf = build_config ~enable_outside_detected_project ~root ~file:name ~is_stdin:false in - Ok {kind; name; file= Stdin; conf} + {kind; name; file= Stdin; conf} in let make_input = function | `Single_file (kind, name, f) -> make_file ?name kind f @@ -638,15 +642,15 @@ let make_action ~enable_outside_detected_project ~root action inputs = let make_inputs = function | (`Single_file _ | `Stdin _) as inp -> let+ inp = make_input inp in - Ok [inp] + [inp] | `Several_files files -> let+ inputs = List.fold_left files ~init:(Ok []) ~f:(fun acc (kind, file) -> - let+ acc = acc in + let* acc = acc in let+ file = make_file kind file in - Ok (file :: acc) ) + file :: acc ) in - Ok (List.rev inputs) + List.rev inputs in match (action, inputs) with | `Print_config, inputs -> @@ -661,7 +665,7 @@ let make_action ~enable_outside_detected_project ~root action inputs = let+ conf = build_config ~enable_outside_detected_project ~root ~file ~is_stdin in - Ok (Print_config conf) + Print_config conf | (`No_action | `Output _ | `Inplace | `Check), `No_input -> Error "Must specify at least one input file, or `-` for stdin" | (`No_action | `Output _), `Several_files _ -> @@ -671,16 +675,16 @@ let make_action ~enable_outside_detected_project ~root action inputs = Error "Cannot specify stdin together with --inplace" | `No_action, ((`Single_file _ | `Stdin _) as inp) -> let+ inp = make_input inp in - Ok (In_out (inp, None)) + In_out (inp, None) | `Output output, ((`Single_file _ | `Stdin _) as inp) -> let+ inp = make_input inp in - Ok (In_out (inp, Some output)) + In_out (inp, Some output) | `Inplace, ((`Single_file _ | `Several_files _) as inputs) -> let+ inputs = make_inputs inputs in - Ok (Inplace inputs) + Inplace inputs | `Check, ((`Single_file _ | `Several_files _ | `Stdin _) as inputs) -> let+ inputs = make_inputs inputs in - Ok (Check inputs) + Check inputs let validate_inputs () = match (!global_conf.inputs, !global_conf.kind, !global_conf.name) with @@ -742,8 +746,8 @@ let validate () = !global_conf.enable_outside_detected_project && Option.is_none root in match - let+ action = validate_action () in - let+ inputs = validate_inputs () in + let* action = validate_action () in + let* inputs = validate_inputs () in make_action ~enable_outside_detected_project ~root action inputs with | Error e -> `Error (false, e) diff --git a/lib/bin_conf/dune b/lib/bin_conf/dune index a071c2f2f4..dc6f287f54 100644 --- a/lib/bin_conf/dune +++ b/lib/bin_conf/dune @@ -2,13 +2,7 @@ (public_name ocamlformat.bin_conf) (name bin_conf) (flags - (:standard - -open - Ocaml_common - -open - Ocamlformat_stdlib - -open - Ocamlformat_result.Global_scope)) + (:standard -open Ocaml_common -open Ocamlformat_stdlib)) (instrumentation (backend bisect_ppx)) (libraries ocamlformat-lib re)) diff --git a/lib/dune b/lib/dune index 547882058e..ebe26f9568 100644 --- a/lib/dune +++ b/lib/dune @@ -23,9 +23,7 @@ -open Parser_extended -open - Ocamlformat_stdlib - -open - Ocamlformat_result.Global_scope)) + Ocamlformat_stdlib)) (instrumentation (backend bisect_ppx)) (libraries @@ -33,7 +31,6 @@ ocaml_common parser_standard parser_extended - ocamlformat_result ocamlformat_stdlib ocaml-version ocp-indent.lib diff --git a/ocamlformat-lib.opam b/ocamlformat-lib.opam index bfa45cc7d5..c7442139ce 100644 --- a/ocamlformat-lib.opam +++ b/ocamlformat-lib.opam @@ -37,7 +37,6 @@ depends: [ "uutf" {>= "1.0.1"} "csexp" {>= "1.4.0"} "astring" - "result" "camlp-streams" "odoc" {with-doc} ] diff --git a/vendor/ocamlformat-result/dune b/vendor/ocamlformat-result/dune deleted file mode 100644 index 3889b01dc7..0000000000 --- a/vendor/ocamlformat-result/dune +++ /dev/null @@ -1,3 +0,0 @@ -(library - (name ocamlformat_result) - (public_name ocamlformat-lib.result)) diff --git a/vendor/ocamlformat-result/ocamlformat_result.ml b/vendor/ocamlformat-result/ocamlformat_result.ml deleted file mode 100644 index 6e84bc245b..0000000000 --- a/vendor/ocamlformat-result/ocamlformat_result.ml +++ /dev/null @@ -1,11 +0,0 @@ -open Result - -module Let_syntax = struct - let ( let+ ) = bind -end - -module Global_scope = struct - type 'a or_error = ('a, [`Msg of string]) t - - include Let_syntax -end diff --git a/vendor/ocamlformat-result/ocamlformat_result.mli b/vendor/ocamlformat-result/ocamlformat_result.mli deleted file mode 100644 index 5c2b52ff85..0000000000 --- a/vendor/ocamlformat-result/ocamlformat_result.mli +++ /dev/null @@ -1,11 +0,0 @@ -open Result - -module Let_syntax : sig - val ( let+ ) : ('a, 'e) t -> ('a -> ('b, 'e) t) -> ('b, 'e) t -end - -module Global_scope : sig - type 'a or_error = ('a, [`Msg of string]) t - - include module type of Let_syntax -end diff --git a/vendor/odoc-parser/dune b/vendor/odoc-parser/dune index 92d5c2360c..5c2cfd229b 100644 --- a/vendor/odoc-parser/dune +++ b/vendor/odoc-parser/dune @@ -7,4 +7,4 @@ (backend bisect_ppx)) (flags (:standard -w -50)) - (libraries astring result camlp-streams)) + (libraries astring camlp-streams)) From 3d8b8e717a130a1959f47676b82ea6a2477ff6c8 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Fri, 22 Sep 2023 15:35:24 +0200 Subject: [PATCH 05/19] Consistent spacing between items with extension (#2450) Structure items with an extension were formatted in a compact way when `module-item-spacing=compact` even though the similar items without an extension would not. This is a problem in future work where the `Pstr_extension` node is no longer used. --- CHANGES.md | 1 + lib/Ast.ml | 9 ++++++--- test/passing/tests/js_source.ml.err | 8 ++++---- test/passing/tests/js_source.ml.ocp | 6 ++++++ test/passing/tests/js_source.ml.ref | 6 ++++++ 5 files changed, 23 insertions(+), 7 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 56d165ecdf..6386f8f204 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -14,6 +14,7 @@ profile. This started with version 0.26.0. ### Fixed - Remove trailing space inside a wrapping empty signature (#2443, @Julow) +- Fix extension-point spacing in structures (#2450, @Julow) ## 0.26.1 (2023-09-15) diff --git a/lib/Ast.ml b/lib/Ast.ml index c190ce6e02..eba0c917ac 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -366,7 +366,7 @@ module Structure_item = struct longident_is_simple c i.txt | _ -> false ) - let allow_adjacent (itmI, cI) (itmJ, cJ) = + let rec allow_adjacent (itmI, cI) (itmJ, cJ) = match Conf. (cI.fmt_opts.module_item_spacing.v, cJ.fmt_opts.module_item_spacing.v) @@ -383,9 +383,12 @@ module Structure_item = struct |Pstr_modtype _, Pstr_modtype _ |Pstr_class _, Pstr_class _ |Pstr_class_type _, Pstr_class_type _ - |Pstr_attribute _, Pstr_attribute _ - |Pstr_extension _, Pstr_extension _ -> + |Pstr_attribute _, Pstr_attribute _ -> true + | ( Pstr_extension ((_, PStr [n1]), _attrs1) + , Pstr_extension ((_, PStr [n2]), _attrs2) ) -> + allow_adjacent (n1, cI) (n2, cJ) + | Pstr_extension _, Pstr_extension _ -> true | _ -> false ) | _ -> true diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index b3089e320a..124fff96ea 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -1,5 +1,5 @@ Warning: tests/js_source.ml:155 exceeds the margin -Warning: tests/js_source.ml:9522 exceeds the margin -Warning: tests/js_source.ml:9625 exceeds the margin -Warning: tests/js_source.ml:9684 exceeds the margin -Warning: tests/js_source.ml:9766 exceeds the margin +Warning: tests/js_source.ml:9528 exceeds the margin +Warning: tests/js_source.ml:9631 exceeds the margin +Warning: tests/js_source.ml:9690 exceeds the margin +Warning: tests/js_source.ml:9772 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 67fd23a7b6..c388b428b4 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -176,16 +176,22 @@ type%foo t = int [@@foo] and t = int [@@foo] type%foo t += T [@@foo] + class%foo x = x [@@foo] + class type%foo x = x [@@foo] + external%foo x : _ = "" [@@foo] + exception%foo X [@foo] + module%foo M = M [@@foo] module%foo rec M : S = M [@@foo] and M : S = M [@@foo] module type%foo S = S [@@foo] + include%foo M [@@foo] open%foo M [@@foo] diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 05e0f63cb2..6749c4d26a 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -176,16 +176,22 @@ type%foo t = int [@@foo] and t = int [@@foo] type%foo t += T [@@foo] + class%foo x = x [@@foo] + class type%foo x = x [@@foo] + external%foo x : _ = "" [@@foo] + exception%foo X [@foo] + module%foo M = M [@@foo] module%foo rec M : S = M [@@foo] and M : S = M [@@foo] module type%foo S = S [@@foo] + include%foo M [@@foo] open%foo M [@@foo] From 7a5b87c569774fadd248b96f0dcb9e62e569cde7 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Mon, 25 Sep 2023 11:47:43 +0100 Subject: [PATCH 06/19] Add a page about how the configuration is computed (#2446) Co-authored-by: Jules Aguillon --- doc/configuration.mld | 50 +++++++++++++++++++++++++++++++++++++++++ doc/editor_setup.mld | 1 + doc/getting_started.mld | 7 +----- doc/index.mld | 1 + 4 files changed, 53 insertions(+), 6 deletions(-) create mode 100644 doc/configuration.mld diff --git a/doc/configuration.mld b/doc/configuration.mld new file mode 100644 index 0000000000..64b6d5faf4 --- /dev/null +++ b/doc/configuration.mld @@ -0,0 +1,50 @@ +{0 How OCamlFormat computes its configuration} + +{1 Configuration files} + +Ocamlformat fetches the following files on the file system: + +1. [.git], [.hg] or [dune-project] +2. [.ocamlformat] and [.ocp-indent] +3. [.ocamlformat-ignore] and [.ocamlformat-enable] + +(1.) files are used to determine the {b project root}, which can be overriden by the [--root] option, they are looked up from the path of the file to format, and upwards following parent directories, until the first one is found. + +(2.) and (3.) are looked up from the path of the file to format, and following up the parents up to the project root. + +(2.) are the {b configuration files}, they contain the options used to configure ocamlformat. A global [.ocamlformat] file can also be used: [$XDG_CONFIG_HOME/ocamlformat] (if defined). + + +{1 How the configuration is built} + +The configuration files are considered in sequence, starting from the root of the project, and down to the directory of the file to format, overriding one or many options at each application. + ++ The initial configuration is equal to the [default] (or [conventional]) profile. ++ The options passed through the configuration files are applied. ++ The options passed through the [OCAMLFORMAT] environment variable are applied, overriding one or many options at a time. ++ The options passed through the command line are applied, overriding one or many options at a time. + +When the option [--enable-outside-detected-project] is set, [.ocamlformat] files outside of the project are read, if no [.ocamlformat] file has been found then then apply the global configuration [$XDG_CONFIG_HOME/ocamlformat] (if defined). The global configuration file is ignore in any other case. + +When this option is not set, [.ocamlformat] files outside of the project are ignored. + +If no configuration file is found, the formatting is disabled. + +{1 Overriding the configuration in the source} + +Note that some options can be overriden directly in the source, with attributes like: + +{@ocaml[ +(* attributes attached to algebraic constructs *) +x [@ocamlformat "option=value,option=value"];; + +(* item attributes, attached to "blocks" *) +y [@@ocamlformat "option=value,option=value"];; + +(* floating attributes, standalone *) +[@@@ocamlformat "option=value,option=value"] +]} + +All "formatting options" (listed in the {{!page-manpage_ocamlformat}manpage}) can be set in attributes. + +Among the non-formatting options only [enable]/[disable] can be set in floatting attributes. diff --git a/doc/editor_setup.mld b/doc/editor_setup.mld index 6a451a34f4..298c77a021 100644 --- a/doc/editor_setup.mld +++ b/doc/editor_setup.mld @@ -3,6 +3,7 @@ {1 Enable formatting outside project} OCamlFormat detects your current project if there is a [.git], a [.hg] or a [dune-project] file in one of the ancestry directories. +For more details, read about {{!page-configuration}how OCamlFormat finds its root project and computes its configuration}. By default, when the option [--enable-outside-detected-project] is not set, [.ocamlformat] files outside of the current project (including the one in [XDG_CONFIG_HOME]) are not read. If no configuration file is found, then the formatting is disabled. diff --git a/doc/getting_started.mld b/doc/getting_started.mld index f1a405000c..070de0fed8 100644 --- a/doc/getting_started.mld +++ b/doc/getting_started.mld @@ -72,12 +72,7 @@ Options can be modified by the means of: - a global [[@@@ocamlformat "option=VAL"]] attribute in the processed file - an [[@@ocamlformat "option=VAL"]] attribute on an expression in the processed file -[.ocamlformat] files in the containing and all ancestor directories for each input file are used, as well as the global [.ocamlformat] file defined in [$XDG_CONFIG_HOME/ocamlformat]. The global [.ocamlformat] file has the lowest priority, then the closer the directory is to the processed file, the higher the priority. - -When the option [--enable-outside-detected-project] is set, [.ocamlformat] files outside of the project (including the one in [XDG_CONFIG_HOME]) are read. The project root of an input file is taken to be the nearest ancestor directory that contains a [.git] or [.hg] or [dune-project] file. -When this option is not set, [.ocamlformat] files outside of the project are ignored. If no configuration file is found, formatting is disabled. - -An [.ocamlformat-ignore] file specifies files that OCamlFormat should ignore. Each line in an [.ocamlformat-ignore] file specifies a filename relative to the directory containing the [.ocamlformat-ignore] file. Lines starting with [#] are ignored and can be used as comments. +For more details, read about {{!page-configuration}how OCamlFormat finds its root project and computes its configuration}. {1 Version} diff --git a/doc/index.mld b/doc/index.mld index 7314ea4c98..b708bac193 100644 --- a/doc/index.mld +++ b/doc/index.mld @@ -9,6 +9,7 @@ OCamlFormat is a tool to format OCaml code. {1 Table of Content} - {{!page-getting_started}Getting started} +- {{!page-configuration}How OCamlFormat computes its configuration} - {{!page-editor_setup}Editor setup} - {{!page-manpage_ocamlformat}Manpage} - {{!page-howtos}How-To's} From 940eea5c219ebf422888a3eea8e62f49bc542380 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Tue, 26 Sep 2023 22:16:25 +0800 Subject: [PATCH 07/19] Update issue templates (#2452) --- .github/ISSUE_TEMPLATE/config.yml | 8 ++++++++ .github/ISSUE_TEMPLATE/feature_request.md | 2 +- .github/ISSUE_TEMPLATE/question.md | 14 ++++++++++++++ .github/ISSUE_TEMPLATE/style_suggestion.md | 18 ++++++++++++++++++ 4 files changed, 41 insertions(+), 1 deletion(-) create mode 100644 .github/ISSUE_TEMPLATE/config.yml create mode 100644 .github/ISSUE_TEMPLATE/question.md create mode 100644 .github/ISSUE_TEMPLATE/style_suggestion.md diff --git a/.github/ISSUE_TEMPLATE/config.yml b/.github/ISSUE_TEMPLATE/config.yml new file mode 100644 index 0000000000..a874e4ac53 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/config.yml @@ -0,0 +1,8 @@ +blank_issues_enabled: false +contact_links: + - name: OCaml Community Forum + url: https://discuss.ocaml.org/ + about: Please ask and answer questions here. + - name: OCaml Community Discord + url: https://discord.gg/cCYQbqN + about: Please ask and answer questions here. diff --git a/.github/ISSUE_TEMPLATE/feature_request.md b/.github/ISSUE_TEMPLATE/feature_request.md index b38e14ec97..7973590b02 100644 --- a/.github/ISSUE_TEMPLATE/feature_request.md +++ b/.github/ISSUE_TEMPLATE/feature_request.md @@ -2,7 +2,7 @@ name: Feature request about: Suggest an idea for this project title: 'Feature request: ...' -labels: Kind/Feature-request +labels: 'Kind/feature-request' assignees: '' --- diff --git a/.github/ISSUE_TEMPLATE/question.md b/.github/ISSUE_TEMPLATE/question.md new file mode 100644 index 0000000000..b7910abbfe --- /dev/null +++ b/.github/ISSUE_TEMPLATE/question.md @@ -0,0 +1,14 @@ +--- +name: Question +about: Do you have a question about ocamlformat? +title: 'Question: ...' +labels: 'Kind/question' +assignees: '' + +--- + +Please give as much context as possible. + +Is your question related to a specific OCaml version? +Is your question related to a specific OCamlFormat version? +Is your question related to a specific formatting profile or option? diff --git a/.github/ISSUE_TEMPLATE/style_suggestion.md b/.github/ISSUE_TEMPLATE/style_suggestion.md new file mode 100644 index 0000000000..5c8976a968 --- /dev/null +++ b/.github/ISSUE_TEMPLATE/style_suggestion.md @@ -0,0 +1,18 @@ +--- +name: Style suggestion +about: Suggest a different formatting style for this project +title: 'Style suggestion: ...' +labels: 'Kind/style-suggestion' +assignees: '' + +--- + +**Current formatting** +Please copy-paste your code and the formatting that is currently applied to it. + +**Describe the formatting you'd like** +A clear and concise description of what you want to happen. + +**Additional context** +Add any other context about the style request here. +What justifies ocamlformat adding this new style? From bc91e42246a7fe184377ab650f66f629e8e378be Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Wed, 27 Sep 2023 17:22:37 +0200 Subject: [PATCH 08/19] Attributes now stay where the user put them (#2451) module [@attr] M = struct end used to be formatted into module = struct end [@@attr] This PR make it so that the user can choose between the two syntaxes, ocamlformat will not change anything. --- CHANGES.md | 1 + lib/Ast.ml | 54 ++++++---- lib/Fmt_ast.ml | 113 +++++++++++--------- test/passing/tests/attributes.ml | 1 + test/passing/tests/attributes.ml.err | 2 +- test/passing/tests/js_source.ml.err | 8 +- test/passing/tests/js_source.ml.ocp | 21 ++-- test/passing/tests/js_source.ml.ref | 21 ++-- test/passing/tests/module_attributes.ml | 7 ++ test/passing/tests/module_attributes.ml.ref | 5 + test/passing/tests/shortcut_ext_attr.ml | 8 +- test/passing/tests/source.ml.ref | 18 ++-- vendor/parser-extended/ast_helper.ml | 22 ++-- vendor/parser-extended/ast_mapper.ml | 26 +++-- vendor/parser-extended/docstrings.ml | 11 ++ vendor/parser-extended/parser.mly | 83 +++++++------- vendor/parser-extended/parsetree.mli | 14 ++- vendor/parser-extended/printast.ml | 18 +++- 18 files changed, 253 insertions(+), 180 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 6386f8f204..e5a4246e2f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -134,6 +134,7 @@ profile. This started with version 0.26.0. - JaneStreet profile: doesn't align infix ops with open paren (#2204, @gpetiot) - Re-use the type let_binding from the parser instead of value_binding, improve the spacing of let-bindings regarding of having extension or comments (#2219, @gpetiot) - The `ocamlformat` package now only contains the binary, the library is available through the `ocamlformat-lib` package (#2230, @gpetiot) +- The position of module and module type attributes is now preserved. (#2451, @emiletrotignon) ### Added diff --git a/lib/Ast.ml b/lib/Ast.ml index eba0c917ac..c47beb25f2 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -105,6 +105,12 @@ module Ext = struct end end +module Ext_attrs = struct + let has_doc ea = + List.exists ~f:Attr.is_doc ea.attrs_before + || List.exists ~f:Attr.is_doc ea.attrs_after +end + module Exp = struct let location x = x.pexp_loc @@ -318,27 +324,30 @@ module Structure_item = struct let has_doc itm = match itm.pstr_desc with | Pstr_attribute atr -> Attr.is_doc atr + (* one attribute list *) | Pstr_eval (_, atrs) |Pstr_value {pvbs_bindings= {pvb_attributes= atrs; _} :: _; _} |Pstr_primitive {pval_attributes= atrs; _} |Pstr_type (_, {ptype_attributes= atrs; _} :: _) |Pstr_typext {ptyext_attributes= atrs; _} |Pstr_recmodule ({pmb_expr= {pmod_attributes= atrs; _}; _} :: _) - |Pstr_modtype {pmtd_attributes= atrs; _} |Pstr_open {popen_attributes= atrs; _} |Pstr_extension (_, atrs) |Pstr_class_type ({pci_attributes= atrs; _} :: _) |Pstr_class ({pci_attributes= atrs; _} :: _) -> List.exists ~f:Attr.is_doc atrs - | Pstr_include - {pincl_mod= {pmod_attributes= atrs1; _}; pincl_attributes= atrs2; _} - |Pstr_exception + | Pstr_exception { ptyexn_attributes= atrs1 ; ptyexn_constructor= {pext_attributes= atrs2; _} ; _ } - |Pstr_module - {pmb_attributes= atrs1; pmb_expr= {pmod_attributes= atrs2; _}; _} -> + |Pstr_include + {pincl_mod= {pmod_attributes= atrs1; _}; pincl_attributes= atrs2; _} + -> List.exists ~f:Attr.is_doc atrs1 || List.exists ~f:Attr.is_doc atrs2 + | Pstr_modtype {pmtd_ext_attrs; _} -> Ext_attrs.has_doc pmtd_ext_attrs + | Pstr_module {pmb_ext_attrs; pmb_expr= {pmod_attributes; _}; _} -> + Ext_attrs.has_doc pmb_ext_attrs + || List.exists ~f:Attr.is_doc pmod_attributes | Pstr_value {pvbs_bindings= []; _} |Pstr_type (_, []) |Pstr_recmodule [] @@ -412,30 +421,33 @@ module Signature_item = struct let has_doc itm = match itm.psig_desc with | Psig_attribute atr -> Attr.is_doc atr + (* one attribute list *) | Psig_value {pval_attributes= atrs; _} |Psig_type (_, {ptype_attributes= atrs; _} :: _) |Psig_typesubst ({ptype_attributes= atrs; _} :: _) |Psig_typext {ptyext_attributes= atrs; _} - |Psig_modtype {pmtd_attributes= atrs; _} - |Psig_modtypesubst {pmtd_attributes= atrs; _} - |Psig_modsubst {pms_attributes= atrs; _} |Psig_open {popen_attributes= atrs; _} |Psig_extension (_, atrs) |Psig_class_type ({pci_attributes= atrs; _} :: _) |Psig_class ({pci_attributes= atrs; _} :: _) -> List.exists ~f:Attr.is_doc atrs - | Psig_recmodule - ( {pmd_type= {pmty_attributes= atrs1; _}; pmd_attributes= atrs2; _} - :: _ ) - |Psig_include + (* two attribute list *) + | Psig_modtype {pmtd_ext_attrs= ea; _} + |Psig_modtypesubst {pmtd_ext_attrs= ea; _} + |Psig_modsubst {pms_ext_attrs= ea; _} -> + Ext_attrs.has_doc ea + | Psig_include {pincl_mod= {pmty_attributes= atrs1; _}; pincl_attributes= atrs2; _} |Psig_exception { ptyexn_attributes= atrs1 ; ptyexn_constructor= {pext_attributes= atrs2; _} - ; _ } - |Psig_module - {pmd_attributes= atrs1; pmd_type= {pmty_attributes= atrs2; _}; _} -> + ; _ } -> List.exists ~f:Attr.is_doc atrs1 || List.exists ~f:Attr.is_doc atrs2 + | Psig_recmodule + ({pmd_type= {pmty_attributes= atrs; _}; pmd_ext_attrs= ea; _} :: _) + |Psig_module {pmd_ext_attrs= ea; pmd_type= {pmty_attributes= atrs; _}; _} + -> + Ext_attrs.has_doc ea || (List.exists ~f:Attr.is_doc) atrs | Psig_type (_, []) |Psig_typesubst [] |Psig_recmodule [] @@ -510,7 +522,7 @@ module Lb = struct end module Mb = struct - let has_doc itm = List.exists ~f:Attr.is_doc itm.pmb_attributes + let has_doc itm = Ext_attrs.has_doc itm.pmb_ext_attrs let is_simple (i, (c : Conf.t)) = Poly.(c.fmt_opts.module_item_spacing.v = `Compact) @@ -524,7 +536,7 @@ module Mb = struct end module Md = struct - let has_doc itm = List.exists ~f:Attr.is_doc itm.pmd_attributes + let has_doc itm = Ext_attrs.has_doc itm.pmd_ext_attrs let is_simple (i, (c : Conf.t)) = Poly.(c.fmt_opts.module_item_spacing.v = `Compact) @@ -669,6 +681,8 @@ include T let is_top = function Top -> true | _ -> false +let attrs_of_ext_attrs ea = ea.attrs_before @ ea.attrs_after + let attributes = function | Pld _ -> [] | Typ x -> x.ptyp_attributes @@ -677,8 +691,8 @@ let attributes = function | Pat x -> x.ppat_attributes | Exp x -> x.pexp_attributes | Lb x -> x.pvb_attributes - | Mb x -> x.pmb_attributes - | Md x -> x.pmd_attributes + | Mb x -> attrs_of_ext_attrs x.pmb_ext_attrs + | Md x -> attrs_of_ext_attrs x.pmd_ext_attrs | Cl x -> x.pcl_attributes | Mty x -> x.pmty_attributes | Mod x -> x.pmod_attributes diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index b96dff413b..26341f8559 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -178,6 +178,10 @@ let update_config_maybe_disabled c loc l f = let c = update_config c l in maybe_disabled c loc l f +let update_config_maybe_disabled_attrs c loc attrs f = + let l = attrs.attrs_before @ attrs.attrs_after in + update_config_maybe_disabled c loc l f + let update_config_maybe_disabled_block c loc l f = let fmt bdy = {empty with opn= Some (open_vbox 2); bdy; cls= close_box} in let c = update_config c l in @@ -463,6 +467,15 @@ let fmt_docstring_around_item ?is_val ?force_before ?fit c attrs = in (doc_before, doc_after, attrs) +(** Returns the documentation before and after the item as well as the + [ext_attrs] before and after attributes, modified. + It is assumed that docstrings can only occurs in [attrs_after]. *) +let fmt_docstring_around_item_attrs ?is_val ?force_before ?fit c attrs = + let doc_before, doc_after, attrs_after = + fmt_docstring_around_item ?is_val ?force_before ?fit c attrs.attrs_after + in + (doc_before, doc_after, attrs.attrs_before, attrs_after) + let fmt_extension_suffix c ext = opt ext (fun name -> str "%" $ fmt_str_loc c name) @@ -2289,7 +2302,9 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) c.conf ( hvbox 2 (fmt_module c ctx keyword ~eqty:":" name args (Some xbody) - xmty [] ~epi:(str "in") ~can_sparse ?ext ~rec_flag:false ) + xmty + ~attrs:(Ast_helper.Attr.ext_attrs ?ext ()) + ~epi:(str "in") ~can_sparse ~rec_flag:false ) $ fmt "@;<1000 0>" $ fmt_expression c (sub_exp ~ctx exp) ) $ fmt_atrs ) @@ -3622,20 +3637,16 @@ and fmt_signature_item c ?ext {ast= si; _} = $ esp $ fmt_opt epi $ fmt_item_attributes c ~pre:(Break (1, 0)) atrs ) $ doc_after ) - | Psig_modtype mtd -> fmt_module_type_declaration ?ext c ctx mtd - | Psig_modtypesubst mtd -> - fmt_module_type_declaration ?ext ~eqty:":=" c ctx mtd + | Psig_modtype mtd -> fmt_module_type_declaration c ctx mtd + | Psig_modtypesubst mtd -> fmt_module_type_declaration ~eqty:":=" c ctx mtd | Psig_module md -> hvbox 0 - (fmt_module_declaration ?ext c ~rec_flag:false ~first:true + (fmt_module_declaration c ~rec_flag:false ~first:true (sub_md ~ctx md) ) - | Psig_modsubst ms -> hvbox 0 (fmt_module_substitution ?ext c ctx ms) + | Psig_modsubst ms -> hvbox 0 (fmt_module_substitution c ctx ms) | Psig_open od -> fmt_open_description ?ext c ~kw_attributes:[] od | Psig_recmodule mds -> - fmt_recmodule c ctx mds - (fmt_module_declaration ?ext) - (fun x -> Md x) - sub_md + fmt_recmodule c ctx mds fmt_module_declaration (fun x -> Md x) sub_md | Psig_type (rec_flag, decls) -> fmt_type c ?ext rec_flag decls ctx | Psig_typext te -> fmt_type_extension ?ext c ctx te | Psig_value vd -> fmt_value_description ?ext c ctx vd @@ -3720,8 +3731,9 @@ and fmt_class_exprs ?ext c ctx cls = $ hovbox 0 @@ Cmts.fmt c cl.pci_loc (doc_before $ class_exprs $ doc_after) ) -and fmt_module c ctx ?rec_ ?ext ?epi ?(can_sparse = false) keyword - ?(eqty = "=") name xargs xbody xmty attributes ~rec_flag = +and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=") + name xargs xbody xmty ~attrs ~rec_flag = + let ext = attrs.attrs_extension in let blk_t = Option.value_map xmty ~default:empty ~f:(fun xmty -> let blk = fmt_module_type ?rec_ c xmty in @@ -3763,24 +3775,25 @@ and fmt_module c ctx ?rec_ ?ext ?epi ?(can_sparse = false) keyword let bdy, epi = fmt_arg ~pro hd in bdy $ fmt_args ~pro:epi tl in - let intro = - str keyword - $ fmt_extension_suffix c ext - $ fmt_if rec_flag " rec" $ str " " $ fmt_str_loc_opt c name - in let single_line = Option.for_all xbody ~f:(fun x -> Mod.is_simple x.ast) && Option.for_all xmty ~f:(fun x -> Mty.is_simple x.ast) && List.for_all xargs ~f:(function {txt= Unit; _} -> true | _ -> false) in + let doc_before, doc_after, attrs_before, attrs_after = + fmt_docstring_around_item_attrs c ~force_before:(not single_line) + ~fit:true attrs + in + let intro = + str keyword + $ fmt_extension_suffix c ext + $ fmt_attributes c ~pre:(Break (1, 0)) attrs_before + $ fmt_if rec_flag " rec" $ str " " $ fmt_str_loc_opt c name + in let compact = Poly.(c.conf.fmt_opts.let_module.v = `Compact) || not can_sparse in let fmt_pro = opt blk_b.pro (fun pro -> fmt "@ " $ pro) in - let doc_before, doc_after, atrs = - fmt_docstring_around_item c ~force_before:(not single_line) ~fit:true - attributes - in hvbox (if compact then 0 else 2) ( doc_before @@ -3799,7 +3812,7 @@ and fmt_module c ctx ?rec_ ?ext ?epi ?(can_sparse = false) keyword $ fmt_if (Option.is_none blk_b.pro && Option.is_some xbody) "@ " $ blk_b.bdy ) $ blk_b.esp $ fmt_opt blk_b.epi - $ fmt_item_attributes c ~pre:(Break (1, 0)) atrs + $ fmt_item_attributes c ~pre:(Break (1, 0)) attrs_after $ doc_after $ opt epi (fun epi -> fmt_or_k compact @@ -3810,26 +3823,25 @@ and fmt_module c ctx ?rec_ ?ext ?epi ?(can_sparse = false) keyword (fmt "@;<1 -2>") $ epi ) ) -and fmt_module_declaration ?ext c ~rec_flag ~first {ast= pmd; _} = +and fmt_module_declaration c ~rec_flag ~first {ast= pmd; _} = protect c (Md pmd) @@ - let {pmd_name; pmd_args; pmd_type; pmd_attributes; pmd_loc} = pmd in - update_config_maybe_disabled c pmd_loc pmd_attributes + let {pmd_name; pmd_args; pmd_type; pmd_ext_attrs= attrs; pmd_loc} = pmd in + update_config_maybe_disabled_attrs c pmd_loc attrs @@ fun c -> let ctx = Md pmd in - let ext = if first then ext else None in let keyword = if first then "module" else "and" in let xmty = sub_mty ~ctx pmd_type in let eqty = match xmty.ast.pmty_desc with Pmty_alias _ -> None | _ -> Some ":" in Cmts.fmt c pmd_loc - (fmt_module ~rec_:rec_flag ?ext c ctx keyword pmd_name pmd_args None - ?eqty (Some xmty) ~rec_flag:(rec_flag && first) pmd_attributes ) + (fmt_module ~rec_:rec_flag c ctx keyword pmd_name pmd_args None ?eqty + (Some xmty) ~rec_flag:(rec_flag && first) ~attrs ) -and fmt_module_substitution ?ext c ctx pms = - let {pms_name; pms_manifest; pms_attributes; pms_loc} = pms in - update_config_maybe_disabled c pms_loc pms_attributes +and fmt_module_substitution c ctx pms = + let {pms_name; pms_manifest; pms_ext_attrs= attrs; pms_loc} = pms in + update_config_maybe_disabled_attrs c pms_loc attrs @@ fun c -> let xmty = (* TODO: improve *) @@ -3840,17 +3852,17 @@ and fmt_module_substitution ?ext c ctx pms = in let pms_name = {pms_name with txt= Some pms_name.txt} in Cmts.fmt c pms_loc - (fmt_module ?ext c ctx "module" ~eqty:":=" pms_name [] None (Some xmty) - pms_attributes ~rec_flag:false ) + (fmt_module c ctx "module" ~eqty:":=" pms_name [] None (Some xmty) ~attrs + ~rec_flag:false ) -and fmt_module_type_declaration ?ext ?eqty c ctx pmtd = - let {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = pmtd in - update_config_maybe_disabled c pmtd_loc pmtd_attributes +and fmt_module_type_declaration ?eqty c ctx pmtd = + let {pmtd_name; pmtd_type; pmtd_ext_attrs= attrs; pmtd_loc} = pmtd in + update_config_maybe_disabled_attrs c pmtd_loc attrs @@ fun c -> let pmtd_name = {pmtd_name with txt= Some pmtd_name.txt} in - fmt_module ?ext ?eqty c ctx "module type" pmtd_name [] None ~rec_flag:false + fmt_module ?eqty c ctx "module type" pmtd_name [] None ~rec_flag:false (Option.map pmtd_type ~f:(sub_mty ~ctx)) - pmtd_attributes + ~attrs and fmt_open_description ?ext c ?(keyword = "open") ~kw_attributes {popen_expr= popen_lid; popen_override; popen_attributes; popen_loc} = @@ -3909,13 +3921,15 @@ and fmt_with_constraint c ctx ~pre = function let m1 = {m1 with txt= Some (str_longident m1.txt)} in let m2 = Some (sub_mty ~ctx m2) in str pre $ break 1 2 - $ fmt_module c ctx "module type" m1 [] None ~rec_flag:false m2 [] + $ fmt_module c ctx "module type" m1 [] None ~rec_flag:false m2 + ~attrs:(Ast_helper.Attr.ext_attrs ()) | Pwith_modtypesubst (m1, m2) -> let m1 = {m1 with txt= Some (str_longident m1.txt)} in let m2 = Some (sub_mty ~ctx m2) in str pre $ break 1 2 $ fmt_module c ctx ~eqty:":=" "module type" m1 [] None ~rec_flag:false - m2 [] + m2 + ~attrs:(Ast_helper.Attr.ext_attrs ()) and fmt_mod_apply c ctx loc attrs ~parens ~dock_struct me_f arg = match me_f.pmod_desc with @@ -4184,7 +4198,7 @@ and fmt_structure_item c ~last:last_item ?ext ~semisemi let keyword = str "include" $ fmt_extension_suffix c ext $ fmt "@ " in fmt_module_statement c ~attributes ~keyword (sub_mod ~ctx pincl_mod) | Pstr_module mb -> - fmt_module_binding ?ext c ~rec_flag:false ~first:true (sub_mb ~ctx mb) + fmt_module_binding c ~rec_flag:false ~first:true (sub_mb ~ctx mb) | Pstr_open {popen_expr; popen_override; popen_attributes= attributes; popen_loc} -> @@ -4201,9 +4215,7 @@ and fmt_structure_item c ~last:last_item ?ext ~semisemi fmt_module_statement c ~attributes ~keyword (sub_mod ~ctx popen_expr) | Pstr_primitive vd -> fmt_value_description ?ext c ctx vd | Pstr_recmodule mbs -> - fmt_recmodule c ctx mbs (fmt_module_binding ?ext) - (fun x -> Mb x) - sub_mb + fmt_recmodule c ctx mbs fmt_module_binding (fun x -> Mb x) sub_mb | Pstr_type (rec_flag, decls) -> fmt_type c ?ext rec_flag decls ctx | Pstr_typext te -> fmt_type_extension ?ext c ctx te | Pstr_value {pvbs_rec= rec_flag; pvbs_bindings= bindings; pvbs_extension} @@ -4228,7 +4240,7 @@ and fmt_structure_item c ~last:last_item ?ext ~semisemi fmt_value_binding c ~rec_flag ?ext ?epi b in fmt_item_list c ctx update_config ast fmt_item bindings - | Pstr_modtype mtd -> fmt_module_type_declaration ?ext c ctx mtd + | Pstr_modtype mtd -> fmt_module_type_declaration c ctx mtd | Pstr_extension (ext, atrs) -> let doc_before, doc_after, atrs = fmt_docstring_around_item c atrs in let box = @@ -4376,12 +4388,12 @@ and fmt_value_binding c ~rec_flag ?ext ?in_ ?epi $ epi ) $ fmt_docstring c ~pro:(fmt "@\n") doc2 -and fmt_module_binding ?ext c ~rec_flag ~first {ast= pmb; _} = +and fmt_module_binding c ~rec_flag ~first {ast= pmb; _} = + let {pmb_name; pmb_ext_attrs= attrs; _} = pmb in protect c (Mb pmb) - @@ update_config_maybe_disabled c pmb.pmb_loc pmb.pmb_attributes + @@ update_config_maybe_disabled_attrs c pmb.pmb_loc attrs @@ fun c -> let ctx = Mb pmb in - let ext = if first then ext else None in let keyword = if first then "module" else "and" in let xbody = sub_mod ~ctx pmb.pmb_expr in let xbody, xmty = @@ -4395,9 +4407,8 @@ and fmt_module_binding ?ext c ~rec_flag ~first {ast= pmb; _} = | _ -> (xbody, None) in Cmts.fmt c pmb.pmb_loc - (fmt_module ~rec_:rec_flag ?ext c ctx keyword - ~rec_flag:(rec_flag && first) ~eqty:":" pmb.pmb_name pmb.pmb_args - (Some xbody) xmty pmb.pmb_attributes ) + (fmt_module ~rec_:rec_flag c ctx keyword ~rec_flag:(rec_flag && first) + ~eqty:":" pmb_name pmb.pmb_args (Some xbody) xmty ~attrs ) let fmt_toplevel_directive c ~semisemi dir = let fmt_dir_arg = function diff --git a/test/passing/tests/attributes.ml b/test/passing/tests/attributes.ml index d37d0b8be8..2d7afb53f6 100644 --- a/test/passing/tests/attributes.ml +++ b/test/passing/tests/attributes.ml @@ -66,6 +66,7 @@ module type M = sig module T : [%ext] [@test7] module T = T [@@test8] + module [@test8] T = T end let f = fun [@inline] [@inline never] x -> x diff --git a/test/passing/tests/attributes.ml.err b/test/passing/tests/attributes.ml.err index 5d08534f53..7d1cbc5de8 100644 --- a/test/passing/tests/attributes.ml.err +++ b/test/passing/tests/attributes.ml.err @@ -1 +1 @@ -Warning: tests/attributes.ml:339 exceeds the margin +Warning: tests/attributes.ml:340 exceeds the margin diff --git a/test/passing/tests/js_source.ml.err b/test/passing/tests/js_source.ml.err index 124fff96ea..95f7fb8536 100644 --- a/test/passing/tests/js_source.ml.err +++ b/test/passing/tests/js_source.ml.err @@ -1,5 +1,5 @@ Warning: tests/js_source.ml:155 exceeds the margin -Warning: tests/js_source.ml:9528 exceeds the margin -Warning: tests/js_source.ml:9631 exceeds the margin -Warning: tests/js_source.ml:9690 exceeds the margin -Warning: tests/js_source.ml:9772 exceeds the margin +Warning: tests/js_source.ml:9531 exceeds the margin +Warning: tests/js_source.ml:9634 exceeds the margin +Warning: tests/js_source.ml:9693 exceeds the margin +Warning: tests/js_source.ml:9775 exceeds the margin diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index c388b428b4..75df97a557 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -185,12 +185,12 @@ external%foo x : _ = "" [@@foo] exception%foo X [@foo] -module%foo M = M [@@foo] +module%foo [@foo] M = M -module%foo rec M : S = M [@@foo] -and M : S = M [@@foo] +module%foo [@foo] rec M : S = M +and [@foo] M : S = M -module type%foo S = S [@@foo] +module type%foo [@foo] S = S include%foo M [@@foo] open%foo M [@@foo] @@ -205,13 +205,16 @@ module type S = sig type%foo t += T [@@foo] exception%foo X [@foo] - module%foo M : S [@@foo] - module%foo rec M : S [@@foo] - and M : S [@@foo] + module%foo [@foo] M : S + + module%foo [@foo] rec M : S + and [@foo] M : S + + module%foo [@foo] M = M + + module type%foo [@foo] S = S - module%foo M = M [@@foo] - module type%foo S = S [@@foo] include%foo M [@@foo] open%foo M [@@foo] class%foo x : t [@@foo] diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 6749c4d26a..8ffad9be24 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -185,12 +185,12 @@ external%foo x : _ = "" [@@foo] exception%foo X [@foo] -module%foo M = M [@@foo] +module%foo [@foo] M = M -module%foo rec M : S = M [@@foo] -and M : S = M [@@foo] +module%foo [@foo] rec M : S = M +and [@foo] M : S = M -module type%foo S = S [@@foo] +module type%foo [@foo] S = S include%foo M [@@foo] open%foo M [@@foo] @@ -205,13 +205,16 @@ module type S = sig type%foo t += T [@@foo] exception%foo X [@foo] - module%foo M : S [@@foo] - module%foo rec M : S [@@foo] - and M : S [@@foo] + module%foo [@foo] M : S + + module%foo [@foo] rec M : S + and [@foo] M : S + + module%foo [@foo] M = M + + module type%foo [@foo] S = S - module%foo M = M [@@foo] - module type%foo S = S [@@foo] include%foo M [@@foo] open%foo M [@@foo] class%foo x : t [@@foo] diff --git a/test/passing/tests/module_attributes.ml b/test/passing/tests/module_attributes.ml index d580d4164c..18a6c8592f 100644 --- a/test/passing/tests/module_attributes.ml +++ b/test/passing/tests/module_attributes.ml @@ -38,3 +38,10 @@ end = struct end (* some arbitrary comment *) [@ocaml.warning "-60"] + +module type A = sig + module [@attr] A := A.B + + module A := A.B [@@attr] +end + diff --git a/test/passing/tests/module_attributes.ml.ref b/test/passing/tests/module_attributes.ml.ref index 11cac6e12c..b30b5d460e 100644 --- a/test/passing/tests/module_attributes.ml.ref +++ b/test/passing/tests/module_attributes.ml.ref @@ -42,3 +42,8 @@ include ( module My_module_name : sig end = struct end (* some arbitrary comment *) [@ocaml.warning "-60"] + +module type A = sig + module [@attr] A := A.B + module A := A.B [@@attr] +end diff --git a/test/passing/tests/shortcut_ext_attr.ml b/test/passing/tests/shortcut_ext_attr.ml index ba22919dad..9707c46aed 100644 --- a/test/passing/tests/shortcut_ext_attr.ml +++ b/test/passing/tests/shortcut_ext_attr.ml @@ -129,14 +129,14 @@ module type S = sig [%%foo: exception X [@@foo]] - [%%foo: module M : S [@@foo]] + [%%foo: module [@foo] M : S] [%%foo: - module rec M : S [@@foo] + module [@foo] rec M : S - and M : S [@@foo]] + and [@foo] M : S] - [%%foo: module M = M [@@foo]] + [%%foo: module [@foo] M = M] [%%foo: module type S = S [@@foo]] diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index d3d4dc618e..80b701989f 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -225,13 +225,13 @@ external%foo x : _ = "" [@@foo] exception%foo X [@foo] -module%foo M = M [@@foo] +module%foo [@foo] M = M -module%foo rec M : S = M [@@foo] +module%foo [@foo] rec M : S = M -and M : S = M [@@foo] +and [@foo] M : S = M -module type%foo S = S [@@foo] +module type%foo [@foo] S = S include%foo M [@@foo] @@ -251,15 +251,15 @@ module type S = sig exception%foo X [@foo] - module%foo M : S [@@foo] + module%foo [@foo] M : S - module%foo rec M : S [@@foo] + module%foo [@foo] rec M : S - and M : S [@@foo] + and [@foo] M : S - module%foo M = M [@@foo] + module%foo [@foo] M = M - module type%foo S = S [@@foo] + module type%foo [@foo] S = S include%foo M [@@foo] diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml index 1af7e480af..442ce1b63f 100644 --- a/vendor/parser-extended/ast_helper.ml +++ b/vendor/parser-extended/ast_helper.ml @@ -54,6 +54,8 @@ module Attr = struct { attr_name = name; attr_payload = payload; attr_loc = loc } + let ext_attrs ?ext ?(before=[]) ?(after=[]) () = + {attrs_extension = ext; attrs_before = before; attrs_after = after } end module Typ = struct @@ -367,51 +369,47 @@ module Val = struct end module Md = struct - let mk ?(loc = !default_loc) ?(attrs = []) + let mk ?(loc = !default_loc) ?(attrs=Attr.ext_attrs ()) ?(docs = empty_docs) ?(text = []) name args typ = { pmd_name = name; pmd_args = args; pmd_type = typ; - pmd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); + pmd_ext_attrs = add_text_attrs' text (add_docs_attrs' docs attrs); pmd_loc = loc; } end module Ms = struct - let mk ?(loc = !default_loc) ?(attrs = []) + let mk ?(loc = !default_loc) ?(attrs=Attr.ext_attrs ()) ?(docs = empty_docs) ?(text = []) name syn = { pms_name = name; pms_manifest = syn; - pms_attributes = - add_text_attrs text (add_docs_attrs docs attrs); + pms_ext_attrs = add_text_attrs' text (add_docs_attrs' docs attrs); pms_loc = loc; } end module Mtd = struct - let mk ?(loc = !default_loc) ?(attrs = []) + let mk ?(loc = !default_loc) ?(attrs=Attr.ext_attrs ()) ?(docs = empty_docs) ?(text = []) ?typ name = { pmtd_name = name; pmtd_type = typ; - pmtd_attributes = - add_text_attrs text (add_docs_attrs docs attrs); + pmtd_ext_attrs = add_text_attrs' text (add_docs_attrs' docs attrs); pmtd_loc = loc; } end module Mb = struct - let mk ?(loc = !default_loc) ?(attrs = []) + let mk ?(loc = !default_loc) ?(attrs=Attr.ext_attrs ()) ?(docs = empty_docs) ?(text = []) name args expr = { pmb_name = name; pmb_args = args; pmb_expr = expr; - pmb_attributes = - add_text_attrs text (add_docs_attrs docs attrs); + pmb_ext_attrs = add_text_attrs' text (add_docs_attrs' docs attrs); pmb_loc = loc; } end diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index 471ddf03ca..b1da740668 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -30,6 +30,7 @@ type mapper = { arg_label: mapper -> Asttypes.arg_label -> Asttypes.arg_label; attribute: mapper -> attribute -> attribute; attributes: mapper -> attribute list -> attribute list; + ext_attrs: mapper -> ext_attrs -> ext_attrs; binding_op: mapper -> binding_op -> binding_op; case: mapper -> case -> case; cases: mapper -> case list -> case list; @@ -771,43 +772,44 @@ let default_mapper = binding_op = E.map_binding_op; module_declaration = - (fun this {pmd_name; pmd_args; pmd_type; pmd_attributes; pmd_loc} -> + (fun this {pmd_name; pmd_args; pmd_type; pmd_ext_attrs; pmd_loc} -> Md.mk (map_loc this pmd_name) (List.map (map_functor_param this) pmd_args) (this.module_type this pmd_type) - ~attrs:(this.attributes this pmd_attributes) + ~attrs:(this.ext_attrs this pmd_ext_attrs) ~loc:(this.location this pmd_loc) ); module_substitution = - (fun this {pms_name; pms_manifest; pms_attributes; pms_loc} -> + (fun this + { pms_name; pms_manifest; pms_ext_attrs; + pms_loc } -> Ms.mk (map_loc this pms_name) (map_loc this pms_manifest) - ~attrs:(this.attributes this pms_attributes) + ~attrs:(this.ext_attrs this pms_ext_attrs) ~loc:(this.location this pms_loc) ); module_type_declaration = - (fun this {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} -> + (fun this {pmtd_name; pmtd_type; pmtd_ext_attrs; pmtd_loc} -> Mtd.mk (map_loc this pmtd_name) ?typ:(map_opt (this.module_type this) pmtd_type) - ~attrs:(this.attributes this pmtd_attributes) + ~attrs:(this.ext_attrs this pmtd_ext_attrs) ~loc:(this.location this pmtd_loc) ); module_binding = - (fun this {pmb_name; pmb_args; pmb_expr; pmb_attributes; pmb_loc} -> + (fun this {pmb_name; pmb_args; pmb_expr; pmb_ext_attrs; pmb_loc} -> Mb.mk (map_loc this pmb_name) (List.map (map_functor_param this) pmb_args) (this.module_expr this pmb_expr) - ~attrs:(this.attributes this pmb_attributes) + ~attrs:(this.ext_attrs this pmb_ext_attrs) ~loc:(this.location this pmb_loc) ); - open_declaration = (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> Opn.mk (this.module_expr this popen_expr) @@ -907,6 +909,12 @@ let default_mapper = } ); attributes = (fun this l -> List.map (this.attribute this) l); + ext_attrs = (fun this e -> + { + attrs_extension = map_opt (map_loc this) e.attrs_extension; + attrs_before = this.attributes this e.attrs_before; + attrs_after = this.attributes this e.attrs_after; + }); payload = (fun this -> function | PStr x -> PStr (this.structure this x) diff --git a/vendor/parser-extended/docstrings.ml b/vendor/parser-extended/docstrings.ml index 32b8e8c468..7cbe4710d8 100644 --- a/vendor/parser-extended/docstrings.ml +++ b/vendor/parser-extended/docstrings.ml @@ -118,6 +118,11 @@ let add_docs_attrs docs attrs = in attrs +(** {!add_docs_attrs} but operate on [ext_attrs]. *) +let add_docs_attrs' docs attrs' = + let open Parsetree in + { attrs' with attrs_after = add_docs_attrs docs attrs'.attrs_after } + (* Docstrings attached to constructors or fields *) type info = docstring option @@ -162,6 +167,12 @@ let add_text_attrs dsl attrs = let fdsl = List.filter (function {ds_body=""} -> false| _ ->true) dsl in (List.map text_attr fdsl) @ attrs + +(** {!add_text_attrs} but operate on [ext_attrs]. *) +let add_text_attrs' text attrs' = + let open Parsetree in + { attrs' with attrs_before = add_text_attrs text attrs'.attrs_before } + (* Find the first non-info docstring in a list, attach it and return it *) let get_docstring ~info dsl = let rec loop = function diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index a7a060cee8..26673cdfae 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -79,8 +79,6 @@ let pstr_exception (te, ext) = (Pstr_exception te, ext) let pstr_include (body, ext) = (Pstr_include body, ext) -let pstr_recmodule (ext, bindings) = - (Pstr_recmodule bindings, ext) let psig_typext (te, ext) = (Psig_typext te, ext) @@ -1345,6 +1343,12 @@ structure_item: Pstr_extension ($1, add_docs_attrs docs $2) } | floating_attribute { Pstr_attribute $1 } + | module_binding + { $1 } + | rec_module_bindings + { Pstr_recmodule $1 } + | module_type_declaration + { Pstr_modtype $1 } ) | wrap_mkstr_ext( primitive_declaration @@ -1357,12 +1361,6 @@ structure_item: { pstr_typext $1 } | str_exception_declaration { pstr_exception $1 } - | module_binding - { $1 } - | rec_module_bindings - { pstr_recmodule $1 } - | module_type_declaration - { let (body, ext) = $1 in (Pstr_modtype body, ext) } | open_declaration { let (body, ext) = $1 in (Pstr_open body, ext) } | class_declarations @@ -1385,9 +1383,9 @@ structure_item: attrs2 = post_item_attributes { let docs = symbol_docs $sloc in let loc = make_loc $sloc in - let attrs = attrs1 @ attrs2 in + let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in let body = Mb.mk name args body ~attrs ~loc ~docs in - Pstr_module body, ext } + Pstr_module body } ; (* The body (right-hand side) of a module binding. *) @@ -1409,8 +1407,8 @@ module_binding_body: (* A group of recursive module bindings. *) %inline rec_module_bindings: - xlist(rec_module_binding, and_module_binding) - { $1 } + rec_module_binding list(and_module_binding) + { $1 :: $2 } ; (* The first binding in a group of recursive module bindings. *) @@ -1425,9 +1423,8 @@ module_binding_body: attrs2 = post_item_attributes { let loc = make_loc $sloc in - let attrs = attrs1 @ attrs2 in + let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in let docs = symbol_docs $sloc in - ext, Mb.mk name args body ~attrs ~loc ~docs } ; @@ -1442,7 +1439,7 @@ module_binding_body: attrs2 = post_item_attributes { let loc = make_loc $sloc in - let attrs = attrs1 @ attrs2 in + let attrs = Attr.ext_attrs ~before:attrs1 ~after:attrs2 () in let docs = symbol_docs $sloc in let text = symbol_text $symbolstartpos in Mb.mk name args body ~attrs ~loc ~text ~docs @@ -1478,10 +1475,10 @@ module_type_declaration: typ = preceded(EQUAL, module_type)? attrs2 = post_item_attributes { - let attrs = attrs1 @ attrs2 in + let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in let loc = make_loc $sloc in let docs = symbol_docs $sloc in - Mtd.mk id ?typ ~attrs ~loc ~docs, ext + Mtd.mk id ?typ ~attrs ~loc ~docs } ; @@ -1597,6 +1594,18 @@ signature_item: | mksig( floating_attribute { Psig_attribute $1 } + | module_declaration + { Psig_module $1 } + | module_alias + { Psig_module $1 } + | module_subst + { Psig_modsubst $1 } + | rec_module_declarations + { Psig_recmodule $1 } + | module_type_declaration + { Psig_modtype $1 } + | module_type_subst + { Psig_modtypesubst $1 } ) { $1 } | wrap_mksig_ext( @@ -1612,18 +1621,6 @@ signature_item: { psig_typext $1 } | sig_exception_declaration { psig_exception $1 } - | module_declaration - { let (body, ext) = $1 in (Psig_module body, ext) } - | module_alias - { let (body, ext) = $1 in (Psig_module body, ext) } - | module_subst - { let (body, ext) = $1 in (Psig_modsubst body, ext) } - | rec_module_declarations - { let (ext, l) = $1 in (Psig_recmodule l, ext) } - | module_type_declaration - { let (body, ext) = $1 in (Psig_modtype body, ext) } - | module_type_subst - { let (body, ext) = $1 in (Psig_modtypesubst body, ext) } | open_description { let (body, ext) = $1 in (Psig_open body, ext) } | include_statement(module_type) @@ -1645,10 +1642,10 @@ signature_item: body = module_type attrs2 = post_item_attributes { - let attrs = attrs1 @ attrs2 in + let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in let loc = make_loc $sloc in let docs = symbol_docs $sloc in - Md.mk name args body ~attrs ~loc ~docs, ext + Md.mk name args body ~attrs ~loc ~docs } ; @@ -1677,10 +1674,10 @@ module_declaration_body: body = module_expr_alias attrs2 = post_item_attributes { - let attrs = attrs1 @ attrs2 in + let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in let loc = make_loc $sloc in let docs = symbol_docs $sloc in - Md.mk name [] body ~attrs ~loc ~docs, ext + Md.mk name [] body ~attrs ~loc ~docs } ; %inline module_expr_alias: @@ -1689,17 +1686,17 @@ module_declaration_body: ; (* A module substitution (in a signature). *) module_subst: - MODULE +MODULE ext = ext attrs1 = attributes uid = mkrhs(UIDENT) COLONEQUAL body = mkrhs(mod_ext_longident) attrs2 = post_item_attributes { - let attrs = attrs1 @ attrs2 in + let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in let loc = make_loc $sloc in let docs = symbol_docs $sloc in - Ms.mk uid body ~attrs ~loc ~docs, ext + Ms.mk uid body ~attrs ~loc ~docs } | MODULE ext attributes mkrhs(UIDENT) COLONEQUAL error { expecting $loc($6) "module path" } @@ -1707,8 +1704,8 @@ module_subst: (* A group of recursive module declarations. *) %inline rec_module_declarations: - xlist(rec_module_declaration, and_module_declaration) - { $1 } + rec_module_declaration list(and_module_declaration) + { $1 :: $2 } ; %inline rec_module_declaration: MODULE @@ -1720,10 +1717,10 @@ module_subst: mty = module_type attrs2 = post_item_attributes { - let attrs = attrs1 @ attrs2 in + let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in let loc = make_loc $sloc in let docs = symbol_docs $sloc in - ext, Md.mk name [] mty ~attrs ~loc ~docs + Md.mk name [] mty ~attrs ~loc ~docs } ; %inline and_module_declaration: @@ -1734,7 +1731,7 @@ module_subst: mty = module_type attrs2 = post_item_attributes { - let attrs = attrs1 @ attrs2 in + let attrs = Attr.ext_attrs ~before:attrs1 ~after:attrs2 () in let docs = symbol_docs $sloc in let loc = make_loc $sloc in let text = symbol_text $symbolstartpos in @@ -1752,10 +1749,10 @@ module_type_subst: typ=module_type attrs2 = post_item_attributes { - let attrs = attrs1 @ attrs2 in + let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in let loc = make_loc $sloc in let docs = symbol_docs $sloc in - Mtd.mk id ~typ ~attrs ~loc ~docs, ext + Mtd.mk id ~typ ~attrs ~loc ~docs } diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index ff8818429d..dea619a38b 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -81,6 +81,12 @@ and payload = | PPat of pattern * expression option (** [? P] or [? P when E], in an attribute or an extension point *) +and ext_attrs = { + attrs_extension : string loc option; (** Short extension syntax, eg. [module%ext Foo ...]. *) + attrs_before : attributes; (** eg. [module Foo [@attr] = ...]. *) + attrs_after : attributes; (** eg. [module Foo = struct end [@@attr]]. *) +} + (** {1 Core language} *) (** {2 Type expressions} *) @@ -918,7 +924,7 @@ and module_declaration = pmd_name: string option loc; pmd_args: functor_parameter loc list; pmd_type: module_type; - pmd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pmd_ext_attrs : ext_attrs; pmd_loc: Location.t; } (** Values of type [module_declaration] represents [S : MT] *) @@ -927,7 +933,7 @@ and module_substitution = { pms_name: string loc; pms_manifest: Longident.t loc; - pms_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pms_ext_attrs : ext_attrs; pms_loc: Location.t; } (** Values of type [module_substitution] represents [S := M] *) @@ -936,7 +942,7 @@ and module_type_declaration = { pmtd_name: string loc; pmtd_type: module_type option; - pmtd_attributes: attributes; (** [... [\@\@id1] [\@\@id2]] *) + pmtd_ext_attrs : ext_attrs; pmtd_loc: Location.t; } (** Values of type [module_type_declaration] represents: @@ -1101,7 +1107,7 @@ and module_binding = pmb_name: string option loc; pmb_args: functor_parameter loc list; pmb_expr: module_expr; - pmb_attributes: attributes; + pmb_ext_attrs : ext_attrs; pmb_loc: Location.t; } (** Values of type [module_binding] represents [module X = ME] *) diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index 1c07ba665b..51f196eecb 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -548,7 +548,15 @@ and attributes i ppf l = line i ppf "attribute %a %a\n" fmt_string_loc a.attr_name fmt_location a.attr_loc; payload (i + 1) ppf a.attr_payload; - ) l; + ) l + +and ext_attrs i ppf attrs = + let i = i + 1 in + option (i + 1) + (fun i ppf ext -> line i ppf "extension %a\n" fmt_string_loc ext) + ppf attrs.attrs_extension; + attributes i ppf attrs.attrs_before; + attributes i ppf attrs.attrs_after and payload i ppf = function | PStr x -> structure i ppf x @@ -846,7 +854,7 @@ and signature_item i ppf x = fmt_string_loc pms.pms_name fmt_longident_loc pms.pms_manifest; fmt_location ppf pms.pms_loc; - attributes i ppf pms.pms_attributes; + ext_attrs i ppf pms.pms_ext_attrs; | Psig_recmodule decls -> line i ppf "Psig_recmodule\n"; list i module_declaration ppf decls; @@ -996,21 +1004,21 @@ and structure_item i ppf x = and module_type_declaration i ppf x = line i ppf "module_type_declaration %a %a\n" fmt_string_loc x.pmtd_name fmt_location x.pmtd_loc; - attributes i ppf x.pmtd_attributes; + ext_attrs i ppf x.pmtd_ext_attrs; modtype_declaration (i+1) ppf x.pmtd_type and module_declaration i ppf pmd = line i ppf "module_declaration %a %a\n" fmt_str_opt_loc pmd.pmd_name fmt_location pmd.pmd_loc; list i functor_parameter ppf pmd.pmd_args; - attributes i ppf pmd.pmd_attributes; + ext_attrs i ppf pmd.pmd_ext_attrs; module_type (i+1) ppf pmd.pmd_type; and module_binding i ppf x = line i ppf "module_binding %a %a\n" fmt_str_opt_loc x.pmb_name fmt_location x.pmb_loc; list i functor_parameter ppf x.pmb_args; - attributes i ppf x.pmb_attributes; + ext_attrs i ppf x.pmb_ext_attrs; module_expr (i+1) ppf x.pmb_expr and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = From ed30ab8284d28a1c2b57fdf2d7c4bd7528029296 Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 5 Oct 2023 14:38:43 +0200 Subject: [PATCH 09/19] Consistent break after string constant argument (#2453) A break is added after wrapping string constants in argument lists. This break was missing for string constants containing explicit line breaks or format hints. --- CHANGES.md | 1 + lib/Fmt_ast.ml | 22 +++++++++---------- .../tests/break_string_literals-never.ml.err | 2 ++ .../tests/break_string_literals-never.ml.ref | 10 +++++++++ test/passing/tests/break_string_literals.ml | 14 ++++++++++++ .../tests/break_string_literals.ml.ref | 13 +++++++++++ test/passing/tests/js_args.ml.ref | 3 ++- 7 files changed, 52 insertions(+), 13 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index e5a4246e2f..83cd9ab638 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -15,6 +15,7 @@ profile. This started with version 0.26.0. - Remove trailing space inside a wrapping empty signature (#2443, @Julow) - Fix extension-point spacing in structures (#2450, @Julow) +- \* Consistent break after string constant argument (#2453, @Julow) ## 0.26.1 (2023-09-15) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 26341f8559..54ec5e33dc 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1417,7 +1417,7 @@ and fmt_fun ?force_closing_paren $ body $ closing $ Cmts.fmt_after c ast.pexp_loc ) -and fmt_label_arg ?(box = true) ?epi ?eol c (lbl, ({ast= arg; _} as xarg)) = +and fmt_label_arg ?(box = true) ?eol c (lbl, ({ast= arg; _} as xarg)) = match (lbl, arg.pexp_desc) with | (Labelled l | Optional l), Pexp_ident {txt= Lident i; loc} when String.equal l.txt i && List.is_empty arg.pexp_attributes -> @@ -1435,15 +1435,13 @@ and fmt_label_arg ?(box = true) ?epi ?eol c (lbl, ({ast= arg; _} as xarg)) = | Optional _ -> str "?" | Nolabel -> noop in - lbl $ fmt_expression c ~box ?epi xarg + lbl $ fmt_expression c ~box xarg | (Labelled _ | Optional _), _ when Cmts.has_after c.cmts xarg.ast.pexp_loc -> let cmts_after = Cmts.fmt_after c xarg.ast.pexp_loc in hvbox_if box 2 ( hvbox_if box 0 - (fmt_expression c - ~pro:(fmt_label lbl ":@;<0 2>") - ~box ?epi xarg ) + (fmt_expression c ~pro:(fmt_label lbl ":@;<0 2>") ~box xarg) $ cmts_after ) | (Labelled _ | Optional _), (Pexp_fun _ | Pexp_newtype _) -> fmt_fun ~box ~label:lbl ~parens:true c xarg @@ -1451,7 +1449,7 @@ and fmt_label_arg ?(box = true) ?epi ?eol c (lbl, ({ast= arg; _} as xarg)) = let label_sep : s = if box || c.conf.fmt_opts.wrap_fun_args.v then ":@," else ":" in - fmt_label lbl label_sep $ fmt_expression c ~box ?epi xarg + fmt_label lbl label_sep $ fmt_expression c ~box xarg and expression_width c xe = String.length @@ -1467,15 +1465,15 @@ and fmt_args_grouped ?epi:(global_epi = noop) c ctx args = | Pexp_fun _ | Pexp_function _ -> Some false | _ -> None in - let epi = - match (lbl, last) with - | _, true -> None - | Nolabel, _ -> Some (fits_breaks "" ~hint:(1000, -1) "") - | _ -> Some (fits_breaks "" ~hint:(1000, -3) "") + let break_after = + match (ast.pexp_desc, c.conf.fmt_opts.break_string_literals.v) with + | Pexp_constant _, `Auto when not last -> + fits_breaks "" ~hint:(1000, -2) "" + | _ -> noop in hovbox (Params.Indent.fun_args_group c.conf ~lbl ast) - (fmt_label_arg c ?box ?epi (lbl, xarg)) + (fmt_label_arg c ?box (lbl, xarg) $ break_after) $ fmt_if_k (not last) (break_unless_newline 1 0) in let fmt_args ~first ~last args = diff --git a/test/passing/tests/break_string_literals-never.ml.err b/test/passing/tests/break_string_literals-never.ml.err index 1a73d22483..a181d8b583 100644 --- a/test/passing/tests/break_string_literals-never.ml.err +++ b/test/passing/tests/break_string_literals-never.ml.err @@ -3,3 +3,5 @@ Warning: tests/break_string_literals.ml:7 exceeds the margin Warning: tests/break_string_literals.ml:11 exceeds the margin Warning: tests/break_string_literals.ml:48 exceeds the margin Warning: tests/break_string_literals.ml:51 exceeds the margin +Warning: tests/break_string_literals.ml:63 exceeds the margin +Warning: tests/break_string_literals.ml:68 exceeds the margin diff --git a/test/passing/tests/break_string_literals-never.ml.ref b/test/passing/tests/break_string_literals-never.ml.ref index 34817d10a0..a4ac9d25bc 100644 --- a/test/passing/tests/break_string_literals-never.ml.ref +++ b/test/passing/tests/break_string_literals-never.ml.ref @@ -58,3 +58,13 @@ let _ = "abc@,def\n\n ghi" let _ = "abc@,def\n\n" let _ = "abc@,def@\n\n" + +let _ = + Pp.textf + "Failed to parse environment variable: %s=%s\nPermitted values: if-exists always never\nDefault: %s" + var v (to_string default) + +let _ = + Pp.textf + "Failed to parse environment variable: %s=%s Permitted values: if-exists always never Default: %s" + var v (to_string default) diff --git a/test/passing/tests/break_string_literals.ml b/test/passing/tests/break_string_literals.ml index 72be2905af..640a4a6edc 100644 --- a/test/passing/tests/break_string_literals.ml +++ b/test/passing/tests/break_string_literals.ml @@ -69,3 +69,17 @@ let _ = "abc@,def\n\nghi" let _ = "abc@,def\n\n ghi" let _ = "abc@,def\n\n" let _ = "abc@,def@\n\n" + +let _ = + Pp.textf + "Failed to parse environment variable: %s=%s\n\ + Permitted values: if-exists always never\n\ + Default: %s" + var v (to_string default) + +let _ = + Pp.textf + "Failed to parse environment variable: %s=%s \ + Permitted values: if-exists always never \ + Default: %s" + var v (to_string default) diff --git a/test/passing/tests/break_string_literals.ml.ref b/test/passing/tests/break_string_literals.ml.ref index 9afe262471..d09646eff8 100644 --- a/test/passing/tests/break_string_literals.ml.ref +++ b/test/passing/tests/break_string_literals.ml.ref @@ -92,3 +92,16 @@ let _ = "abc@,def\n\n ghi" let _ = "abc@,def\n\n" let _ = "abc@,def@\n\n" + +let _ = + Pp.textf + "Failed to parse environment variable: %s=%s\n\ + Permitted values: if-exists always never\n\ + Default: %s" + var v (to_string default) + +let _ = + Pp.textf + "Failed to parse environment variable: %s=%s Permitted values: \ + if-exists always never Default: %s" + var v (to_string default) diff --git a/test/passing/tests/js_args.ml.ref b/test/passing/tests/js_args.ml.ref index 8addea5617..cfdd91ada4 100644 --- a/test/passing/tests/js_args.ml.ref +++ b/test/passing/tests/js_args.ml.ref @@ -33,7 +33,8 @@ let () = messages := Message_store.create (Session_id.of_string "") (* Tuareg indents these lines too far to the left. *) - "herd-retransmitter" Message_store.Message_size.Byte + "herd-retransmitter" + Message_store.Message_size.Byte let () = raise From ab3b75b36dcbe5fe697f617a91579c5063b283f8 Mon Sep 17 00:00:00 2001 From: Emile Trotignon Date: Thu, 5 Oct 2023 17:23:59 +0200 Subject: [PATCH 10/19] Fix formatting of floating docs between recursive modules (#2455) This fixes a bug that was introduced in commit bc91e42 (pr #2451) --- CHANGES.md | 2 +- test/passing/tests/comment_in_modules.ml | 11 +++++++++++ test/passing/tests/comment_in_modules.ml.ref | 7 +++++++ vendor/parser-extended/docstrings.ml | 2 +- 4 files changed, 20 insertions(+), 2 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 83cd9ab638..83f0899625 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -135,7 +135,7 @@ profile. This started with version 0.26.0. - JaneStreet profile: doesn't align infix ops with open paren (#2204, @gpetiot) - Re-use the type let_binding from the parser instead of value_binding, improve the spacing of let-bindings regarding of having extension or comments (#2219, @gpetiot) - The `ocamlformat` package now only contains the binary, the library is available through the `ocamlformat-lib` package (#2230, @gpetiot) -- The position of module and module type attributes is now preserved. (#2451, @emiletrotignon) +- The position of module and module type attributes is now preserved. (#2451, #2455, @emiletrotignon) ### Added diff --git a/test/passing/tests/comment_in_modules.ml b/test/passing/tests/comment_in_modules.ml index 8beafd1a66..0bcce52768 100644 --- a/test/passing/tests/comment_in_modules.ml +++ b/test/passing/tests/comment_in_modules.ml @@ -25,3 +25,14 @@ module A (A:sig end) (* comment *) (B: sig end) : sig end = struct end module A (A:sig end) (* comment *) : sig end = struct end module (* comment *) A (A : sig end) : sig end = struct end + +module rec A : A = + struct + + end + +(** floatting *) + +and B : B = struct end +(** about b *) + diff --git a/test/passing/tests/comment_in_modules.ml.ref b/test/passing/tests/comment_in_modules.ml.ref index 24e597662b..66b488c68f 100644 --- a/test/passing/tests/comment_in_modules.ml.ref +++ b/test/passing/tests/comment_in_modules.ml.ref @@ -27,3 +27,10 @@ module A (A : sig end) (* comment *) (B : sig end) : sig end = struct end module A (A : sig end) : sig end = (* comment *) struct end module (* comment *) A (A : sig end) : sig end = struct end + +module rec A : A = struct end + +(** floatting *) + +(** about b *) +and B : B = struct end diff --git a/vendor/parser-extended/docstrings.ml b/vendor/parser-extended/docstrings.ml index 7cbe4710d8..b8010ae393 100644 --- a/vendor/parser-extended/docstrings.ml +++ b/vendor/parser-extended/docstrings.ml @@ -171,7 +171,7 @@ let add_text_attrs dsl attrs = (** {!add_text_attrs} but operate on [ext_attrs]. *) let add_text_attrs' text attrs' = let open Parsetree in - { attrs' with attrs_before = add_text_attrs text attrs'.attrs_before } + { attrs' with attrs_after = add_text_attrs text attrs'.attrs_after } (* Find the first non-info docstring in a list, attach it and return it *) let get_docstring ~info dsl = From d664fa2254479195f9fe0099c5847cb79299d17f Mon Sep 17 00:00:00 2001 From: Jules Aguillon Date: Thu, 5 Oct 2023 17:25:56 +0200 Subject: [PATCH 11/19] Remove incorrect `fmt_expression ~epi` mechanism (#2445) This argument doesn't work similarly to the `~epi` argument of other functions. It meant different things depending on the expression: - `Pexp_match` and `Pexp_apply`: it was similar to `~pro`. - `Pexp_constant`: like the usual `~epi` but was passed a break. - all other cases: it was not used. These rules are now handled in `fmt_args_grouped`, the only place where they made sense. The `~epi` argument is removed. In the first case, the `~pro` argument is used instead. This requires refactoring `fmt_expression` to make sure that every cases use `~pro` exactly once. --- CHANGES.md | 1 + lib/Fmt_ast.ml | 925 ++++++++++-------- test/passing/dune.inc | 20 +- ...cp_indent_compat-break_colon_after.ml.opts | 2 + ...ocp_indent_compat-break_colon_after.ml.ref | 93 ++ test/passing/tests/ocp_indent_compat.ml | 72 +- test/passing/tests/ocp_indent_compat.ml.err | 1 - test/passing/tests/ocp_indent_compat.ml.opts | 2 + 8 files changed, 616 insertions(+), 500 deletions(-) create mode 100644 test/passing/tests/ocp_indent_compat-break_colon_after.ml.opts create mode 100644 test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref create mode 100644 test/passing/tests/ocp_indent_compat.ml.opts diff --git a/CHANGES.md b/CHANGES.md index 83f0899625..9e078cf01f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -16,6 +16,7 @@ profile. This started with version 0.26.0. - Remove trailing space inside a wrapping empty signature (#2443, @Julow) - Fix extension-point spacing in structures (#2450, @Julow) - \* Consistent break after string constant argument (#2453, @Julow) +- Fix invalid syntax generated with `ocp-indent-compat` (#2445, @Julow) ## 0.26.1 (2023-09-15) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 54ec5e33dc..466d3cae99 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1596,15 +1596,14 @@ and fmt_infix_op_args c ~parens xexp op_args = true | _ -> false in - let fmt_arg ~epi ~very_last xarg = + let fmt_arg ~pro ~very_last xarg = let parens = ((not very_last) && exposed_right_exp Ast.Non_apply xarg.ast) || parenze_exp xarg in if Params.Exp.Infix_op_arg.dock c.conf xarg then - (* Indentation of docked fun or function start before the operator. - Warning: [fmt_expression] doesn't use the [epi] in every case. *) - hovbox 2 (fmt_expression c ~parens ~box:false ~epi xarg) + (* Indentation of docked fun or function start before the operator. *) + hovbox 2 (fmt_expression c ~parens ~box:false ~pro xarg) else let expr_box = match xarg.ast.pexp_desc with @@ -1612,7 +1611,7 @@ and fmt_infix_op_args c ~parens xexp op_args = | _ -> None in hvbox 0 - ( epi + ( pro $ hovbox_if (not very_last) 2 (fmt_expression c ?box:expr_box ~parens xarg) ) in @@ -1623,7 +1622,7 @@ and fmt_infix_op_args c ~parens xexp op_args = (fun ~first ~last (cmts_before, cmts_after, (op, xarg)) -> let very_first = first_grp && first in let very_last = last_grp && last in - let epi, before_arg = + let pro, before_arg = let break = if very_last && is_not_indented xarg then fmt "@ " else fmt_if (not very_first) " " @@ -1633,7 +1632,7 @@ and fmt_infix_op_args c ~parens xexp op_args = | None -> (op $ break, noop) in fmt_opt cmts_before $ before_arg - $ fmt_arg ~epi ~very_last xarg + $ fmt_arg ~pro ~very_last xarg $ fmt_if_k (not last) (break 1 0) ) ) $ fmt_if_k (not last_grp) (break 1 0) in @@ -1667,11 +1666,11 @@ and fmt_pat_cons c ~parens args = Params.Exp.Infix_op_arg.wrap c.conf ~parens ~parens_nested:false (list_fl groups fmt_op_arg_group) -and fmt_match c ?epi ~parens ?ext ctx xexp cs e0 keyword = +and fmt_match c ?pro ~parens ?ext ctx xexp cs e0 keyword = let ctx0 = xexp.ctx in let indent = Params.match_indent c.conf ~parens ~ctx:ctx0 in hvbox indent - ( fmt_opt epi + ( fmt_opt pro $ Params.Exp.wrap c.conf ~parens ~disambiguate:true @@ Params.Align.match_ c.conf ~xexp @@ ( hvbox 0 @@ -1683,8 +1682,8 @@ and fmt_match c ?epi ~parens ?ext ctx xexp cs e0 keyword = $ fmt "@ with" ) $ fmt "@ " $ fmt_cases c ctx cs ) ) -and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) - ?ext ({ast= exp; ctx= ctx0} as xexp) = +and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens + ?(indent_wrap = 0) ?ext ({ast= exp; ctx= ctx0} as xexp) = protect c (Exp exp) @@ let {pexp_desc; pexp_loc; pexp_attributes; _} = exp in @@ -1701,7 +1700,6 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) in hvbox_if box 0 ~name:"expr" @@ fmt_cmts - @@ (fun fmt -> fmt_opt pro $ fmt) @@ match pexp_desc with | Pexp_apply (_, []) -> impossible "not produced by parser" @@ -1725,19 +1723,20 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) ~break in let fmt_grp grp = list grp " ;@ " (fmt_expression c) in - hvbox 0 - (Params.parens_if parens c.conf - ( hvbox c.conf.fmt_opts.extension_indent.v - (wrap "[" "]" - ( str "%" - $ hovbox 2 - ( fmt_str_loc c name $ str " fun " - $ fmt_attributes c ~suf:" " call.pexp_attributes - $ fmt_fun_args c xargs $ fmt_opt fmt_cstr $ fmt "@ ->" - ) - $ fmt "@ " $ fmt_expression c xbody ) ) - $ fmt "@ ;@ " - $ list grps " ;@;<1000 0>" fmt_grp ) ) + pro + $ hvbox 0 + (Params.parens_if parens c.conf + ( hvbox c.conf.fmt_opts.extension_indent.v + (wrap "[" "]" + ( str "%" + $ hovbox 2 + ( fmt_str_loc c name $ str " fun " + $ fmt_attributes c ~suf:" " call.pexp_attributes + $ fmt_fun_args c xargs $ fmt_opt fmt_cstr + $ fmt "@ ->" ) + $ fmt "@ " $ fmt_expression c xbody ) ) + $ fmt "@ ;@ " + $ list grps " ;@;<1000 0>" fmt_grp ) ) | Pexp_infix ( {txt= "|>"; loc} , e0 @@ -1751,20 +1750,21 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) ; _ } ) -> let xargs, xbody = Sugar.fun_ c.cmts (sub_exp ~ctx:(Str pld) retn) in let fmt_cstr, xbody = type_constr_and_body c xbody in - hvbox 0 - (Params.Exp.wrap c.conf ~parens - ( fmt_expression c (sub_exp ~ctx e0) - $ fmt "@\n" - $ Cmts.fmt c loc (fmt "|>@\n") - $ hvbox c.conf.fmt_opts.extension_indent.v - (wrap "[" "]" - ( str "%" - $ hovbox 2 - ( fmt_str_loc c name $ str " fun " - $ fmt_attributes c ~suf:" " retn.pexp_attributes - $ fmt_fun_args c xargs $ fmt_opt fmt_cstr $ fmt "@ ->" - ) - $ fmt "@ " $ fmt_expression c xbody ) ) ) ) + pro + $ hvbox 0 + (Params.Exp.wrap c.conf ~parens + ( fmt_expression c (sub_exp ~ctx e0) + $ fmt "@\n" + $ Cmts.fmt c loc (fmt "|>@\n") + $ hvbox c.conf.fmt_opts.extension_indent.v + (wrap "[" "]" + ( str "%" + $ hovbox 2 + ( fmt_str_loc c name $ str " fun " + $ fmt_attributes c ~suf:" " retn.pexp_attributes + $ fmt_fun_args c xargs $ fmt_opt fmt_cstr + $ fmt "@ ->" ) + $ fmt "@ " $ fmt_expression c xbody ) ) ) ) | Pexp_infix ({txt= ":="; loc}, r, v) when is_simple c.conf (expression_width c) (sub_exp ~ctx r) -> let bol_indent = Params.Indent.assignment_operator_bol c.conf in @@ -1779,19 +1779,20 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) Cmts.fmt_before c loc ~pro:(break 1 indent) ~epi:adj ~adj in let cmts_after = Cmts.fmt_after c loc ~pro:noop ~epi:noop in - Params.parens_if parens c.conf - (hovbox 0 - ( match c.conf.fmt_opts.assignment_operator.v with - | `Begin_line -> - hvbox 0 (fmt_expression c (sub_exp ~ctx r) $ cmts_before) - $ break 1 bol_indent $ fmt ":= " $ cmts_after - $ hvbox 2 (fmt_expression c (sub_exp ~ctx v)) - | `End_line -> - hvbox 0 - ( hvbox 0 (fmt_expression c (sub_exp ~ctx r) $ cmts_before) - $ str " :=" ) - $ fmt "@;<1 2>" $ cmts_after - $ hvbox 2 (fmt_expression c (sub_exp ~ctx v)) ) ) + pro + $ Params.parens_if parens c.conf + (hovbox 0 + ( match c.conf.fmt_opts.assignment_operator.v with + | `Begin_line -> + hvbox 0 (fmt_expression c (sub_exp ~ctx r) $ cmts_before) + $ break 1 bol_indent $ fmt ":= " $ cmts_after + $ hvbox 2 (fmt_expression c (sub_exp ~ctx v)) + | `End_line -> + hvbox 0 + ( hvbox 0 (fmt_expression c (sub_exp ~ctx r) $ cmts_before) + $ str " :=" ) + $ fmt "@;<1 2>" $ cmts_after + $ hvbox 2 (fmt_expression c (sub_exp ~ctx v)) ) ) | Pexp_prefix ({txt= ("~-" | "~-." | "~+" | "~+.") as op; loc}, e1) -> let op = if Location.width loc = String.length op - 1 then @@ -1799,16 +1800,18 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) else op in let spc = fmt_if (Exp.exposed_left e1) "@ " in - Params.parens_if parens c.conf - ( Cmts.fmt c pexp_loc - @@ hvbox 2 (str op $ spc $ fmt_expression c (sub_exp ~ctx e1)) - $ fmt_atrs ) + pro + $ Params.parens_if parens c.conf + ( Cmts.fmt c pexp_loc + @@ hvbox 2 (str op $ spc $ fmt_expression c (sub_exp ~ctx e1)) + $ fmt_atrs ) | Pexp_infix (({txt= id; _} as op), l, ({pexp_desc= Pexp_ident _; _} as r)) when Std_longident.String_id.is_hash_getter id -> - Params.parens_if parens c.conf - ( fmt_expression c (sub_exp ~ctx l) - $ hvbox 0 (fmt_str_loc c op) - $ fmt_expression c (sub_exp ~ctx r) ) + pro + $ Params.parens_if parens c.conf + ( fmt_expression c (sub_exp ~ctx l) + $ hvbox 0 (fmt_str_loc c op) + $ fmt_expression c (sub_exp ~ctx r) ) | Pexp_infix (op, l, ({pexp_desc= Pexp_fun _; pexp_loc; pexp_attributes; _} as r)) when not c.conf.fmt_opts.break_infix_before_func.v -> @@ -1827,27 +1830,28 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) true | _ -> false in - wrap_fits_breaks_if c.conf parens "(" ")" - ( hovbox 0 - (wrap_if has_attr "(" ")" - ( hvbox 2 - ( hvbox indent_wrap - ( fmt_expression ~indent_wrap c (sub_exp ~ctx l) - $ fmt "@;" - $ hovbox 2 - ( hvbox 0 - ( fmt_str_loc c op $ fmt "@ " $ cmts_before - $ fmt_if parens_r "(" $ str "fun " ) - $ fmt_attributes c pexp_attributes ~suf:" " - $ hvbox_if - (not c.conf.fmt_opts.wrap_fun_args.v) - 4 - (fmt_fun_args c xargs $ fmt_opt fmt_cstr) - $ fmt "@ ->" ) ) - $ pre_body ) - $ fmt_or followed_by_infix_op "@;<1000 0>" "@ " - $ body $ fmt_if parens_r ")" $ cmts_after ) ) - $ fmt_atrs ) + pro + $ wrap_fits_breaks_if c.conf parens "(" ")" + ( hovbox 0 + (wrap_if has_attr "(" ")" + ( hvbox 2 + ( hvbox indent_wrap + ( fmt_expression ~indent_wrap c (sub_exp ~ctx l) + $ fmt "@;" + $ hovbox 2 + ( hvbox 0 + ( fmt_str_loc c op $ fmt "@ " $ cmts_before + $ fmt_if parens_r "(" $ str "fun " ) + $ fmt_attributes c pexp_attributes ~suf:" " + $ hvbox_if + (not c.conf.fmt_opts.wrap_fun_args.v) + 4 + (fmt_fun_args c xargs $ fmt_opt fmt_cstr) + $ fmt "@ ->" ) ) + $ pre_body ) + $ fmt_or followed_by_infix_op "@;<1000 0>" "@ " + $ body $ fmt_if parens_r ")" $ cmts_after ) ) + $ fmt_atrs ) | Pexp_infix ( op , l @@ -1858,19 +1862,20 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) let xr = sub_exp ~ctx r in let parens_r = parenze_exp xr in let indent = Params.Indent.function_ c.conf ~parens xr in - Params.parens_if parens c.conf - (hvbox indent - ( hvbox 0 - ( fmt_expression c (sub_exp ~ctx l) - $ fmt "@;" - $ hovbox 2 - ( hvbox 0 - ( fmt_str_loc c op $ fmt "@ " $ cmts_before - $ fmt_if parens_r "( " $ str "function" - $ fmt_extension_suffix c ext ) - $ fmt_attributes c pexp_attributes ) ) - $ fmt "@ " $ fmt_cases c (Exp r) cs $ fmt_if parens_r " )" - $ cmts_after ) ) + pro + $ Params.parens_if parens c.conf + (hvbox indent + ( hvbox 0 + ( fmt_expression c (sub_exp ~ctx l) + $ fmt "@;" + $ hovbox 2 + ( hvbox 0 + ( fmt_str_loc c op $ fmt "@ " $ cmts_before + $ fmt_if parens_r "( " $ str "function" + $ fmt_extension_suffix c ext ) + $ fmt_attributes c pexp_attributes ) ) + $ fmt "@ " $ fmt_cases c (Exp r) cs $ fmt_if parens_r " )" + $ cmts_after ) ) | Pexp_infix _ -> let op_args = Sugar.Exp.infix c.cmts (prec_ast (Exp exp)) xexp in let inner_wrap = parens || has_attr in @@ -1920,18 +1925,20 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) (fmt_before_cmts, fmt_after_cmts, (fmt_op, arg)) | None -> (None, None, (noop, arg)) ) in - hvbox_if outer_wrap 0 - (Params.parens_if outer_wrap c.conf - (hvbox indent_wrap - ( fmt_infix_op_args ~parens:inner_wrap c xexp infix_op_args - $ fmt_atrs ) ) ) + pro + $ hvbox_if outer_wrap 0 + (Params.parens_if outer_wrap c.conf + (hvbox indent_wrap + ( fmt_infix_op_args ~parens:inner_wrap c xexp infix_op_args + $ fmt_atrs ) ) ) | Pexp_prefix (op, e) -> let has_cmts = Cmts.has_before c.cmts e.pexp_loc in - hvbox 2 - (Params.Exp.wrap c.conf ~parens - ( fmt_str_loc c op $ fmt_if has_cmts "@," - $ fmt_expression c ~box (sub_exp ~ctx e) - $ fmt_atrs ) ) + pro + $ hvbox 2 + (Params.Exp.wrap c.conf ~parens + ( fmt_str_loc c op $ fmt_if has_cmts "@," + $ fmt_expression c ~box (sub_exp ~ctx e) + $ fmt_atrs ) ) | Pexp_apply (e0, e1N1) -> ( let wrap = if c.conf.fmt_opts.wrap_fun_args.v then Fn.id else hvbox 2 @@ -1950,8 +1957,7 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) (not c.conf.fmt_opts.ocp_indent_compat.v) || Location.line_difference e0.pexp_loc last_arg.pexp_loc = 0 in - if parens || not dock_fun_arg then (noop, fmt_opt epi) - else (fmt_opt epi, noop) + if parens || not dock_fun_arg then (noop, pro) else (pro, noop) in match last_arg.pexp_desc with | Pexp_fun (_, _, _, eN1_body) @@ -2055,102 +2061,115 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) Fit else Break in - fmt_opt epi $ fmt_if parens "(" + pro $ fmt_if parens "(" $ hvbox 2 ( fmt_args_grouped ~epi:fmt_atrs e0 e1N1 $ fmt_if_k parens (closing_paren c ~force ~offset:(-3)) ) ) | Pexp_array [] -> - hvbox 0 - (Params.parens_if parens c.conf - ( wrap_fits_breaks c.conf "[|" "|]" (Cmts.fmt_within c pexp_loc) - $ fmt_atrs ) ) + pro + $ hvbox 0 + (Params.parens_if parens c.conf + ( wrap_fits_breaks c.conf "[|" "|]" (Cmts.fmt_within c pexp_loc) + $ fmt_atrs ) ) | Pexp_array e1N -> let p = Params.get_array_expr c.conf in - hvbox_if has_attr 0 - (Params.parens_if parens c.conf - ( p.box - (fmt_expressions c (expression_width c) (sub_exp ~ctx) e1N - (sub_exp ~ctx >> fmt_expression c) - p pexp_loc ) - $ fmt_atrs ) ) + pro + $ hvbox_if has_attr 0 + (Params.parens_if parens c.conf + ( p.box + (fmt_expressions c (expression_width c) (sub_exp ~ctx) e1N + (sub_exp ~ctx >> fmt_expression c) + p pexp_loc ) + $ fmt_atrs ) ) | Pexp_list e1N -> let p = Params.get_list_expr c.conf in let offset = if c.conf.fmt_opts.dock_collection_brackets.v then 0 else 2 in let cmt_break = break 1 offset in - hvbox_if has_attr 0 - (Params.parens_if parens c.conf - ( p.box - (fmt_expressions c (expression_width c) (sub_exp ~ctx) e1N - (fun e -> - let fmt_cmts = Cmts.fmt c ~eol:cmt_break e.pexp_loc in - fmt_cmts @@ (sub_exp ~ctx >> fmt_expression c) e ) - p pexp_loc ) - $ fmt_atrs ) ) + pro + $ hvbox_if has_attr 0 + (Params.parens_if parens c.conf + ( p.box + (fmt_expressions c (expression_width c) (sub_exp ~ctx) e1N + (fun e -> + let fmt_cmts = Cmts.fmt c ~eol:cmt_break e.pexp_loc in + fmt_cmts @@ (sub_exp ~ctx >> fmt_expression c) e ) + p pexp_loc ) + $ fmt_atrs ) ) | Pexp_assert e0 -> let paren_body = if Exp.is_symbol e0 || Exp.is_monadic_binding e0 then not (List.is_empty e0.pexp_attributes) else parenze_exp (sub_exp ~ctx e0) in - hovbox 0 - (Params.parens_if parens c.conf - (hvbox 0 - ( hvbox 2 - ( str "assert" - $ fmt_extension_suffix c ext - $ fmt_or paren_body " (@," "@ " - $ fmt_expression c ~parens:false (sub_exp ~ctx e0) ) - $ fmt_if_k paren_body (closing_paren c) - $ fmt_atrs ) ) ) + pro + $ hovbox 0 + (Params.parens_if parens c.conf + (hvbox 0 + ( hvbox 2 + ( str "assert" + $ fmt_extension_suffix c ext + $ fmt_or paren_body " (@," "@ " + $ fmt_expression c ~parens:false (sub_exp ~ctx e0) ) + $ fmt_if_k paren_body (closing_paren c) + $ fmt_atrs ) ) ) | Pexp_constant const -> - Params.parens_if - (parens || not (List.is_empty pexp_attributes)) - c.conf - (fmt_constant c ?epi const $ fmt_atrs) + pro + $ Params.parens_if + (parens || not (List.is_empty pexp_attributes)) + c.conf + (fmt_constant c const $ fmt_atrs) | Pexp_constraint (e, t) -> - hvbox - (Params.Indent.exp_constraint c.conf) - ( wrap_fits_breaks ~space:false c.conf "(" ")" - ( fmt_expression c (sub_exp ~ctx e) - $ fmt "@ : " - $ fmt_core_type c (sub_typ ~ctx t) ) - $ fmt_atrs ) + pro + $ hvbox + (Params.Indent.exp_constraint c.conf) + ( wrap_fits_breaks ~space:false c.conf "(" ")" + ( fmt_expression c (sub_exp ~ctx e) + $ fmt "@ : " + $ fmt_core_type c (sub_typ ~ctx t) ) + $ fmt_atrs ) | Pexp_construct ({txt= Lident (("()" | "[]") as txt); loc}, None) -> let opn = char txt.[0] and cls = char txt.[1] in - let pro = str " " and epi = str " " in - Cmts.fmt c loc - @@ hvbox 0 - (Params.parens_if parens c.conf - ( wrap_k opn cls (Cmts.fmt_within c ~pro ~epi pexp_loc) - $ fmt_atrs ) ) + pro + $ Cmts.fmt c loc + @@ hvbox 0 + (Params.parens_if parens c.conf + ( wrap_k opn cls + (Cmts.fmt_within c ~pro:(str " ") ~epi:(str " ") pexp_loc) + $ fmt_atrs ) ) | Pexp_construct (lid, None) -> - Params.parens_if parens c.conf (fmt_longident_loc c lid $ fmt_atrs) + pro + $ Params.parens_if parens c.conf (fmt_longident_loc c lid $ fmt_atrs) | Pexp_cons l -> - Cmts.fmt c pexp_loc - ( hvbox indent_wrap - (fmt_infix_op_args c ~parens xexp - (List.mapi l ~f:(fun i e -> - (None, None, (fmt_if (i > 0) "::", sub_exp ~ctx e)) ) ) ) - $ fmt_atrs ) + pro + $ Cmts.fmt c pexp_loc + ( hvbox indent_wrap + (fmt_infix_op_args c ~parens xexp + (List.mapi l ~f:(fun i e -> + (None, None, (fmt_if (i > 0) "::", sub_exp ~ctx e)) ) + ) ) + $ fmt_atrs ) | Pexp_construct (lid, Some arg) -> - Params.parens_if parens c.conf - ( hvbox 2 - ( fmt_longident_loc c lid $ fmt "@ " - $ fmt_expression c (sub_exp ~ctx arg) ) - $ fmt_atrs ) + pro + $ Params.parens_if parens c.conf + ( hvbox 2 + ( fmt_longident_loc c lid $ fmt "@ " + $ fmt_expression c (sub_exp ~ctx arg) ) + $ fmt_atrs ) | Pexp_variant (s, arg) -> - hvbox 2 - (Params.parens_if parens c.conf - ( variant_var c s - $ opt arg (fmt "@ " >$ (sub_exp ~ctx >> fmt_expression c)) - $ fmt_atrs ) ) + pro + $ hvbox 2 + (Params.parens_if parens c.conf + ( variant_var c s + $ opt arg (fmt "@ " >$ (sub_exp ~ctx >> fmt_expression c)) + $ fmt_atrs ) ) | Pexp_field (exp, lid) -> - hvbox 2 - (Params.parens_if parens c.conf - ( fmt_expression c (sub_exp ~ctx exp) - $ fmt "@,." $ fmt_longident_loc c lid $ fmt_atrs ) ) + pro + $ hvbox 2 + (Params.parens_if parens c.conf + ( fmt_expression c (sub_exp ~ctx exp) + $ fmt "@,." $ fmt_longident_loc c lid $ fmt_atrs ) ) | Pexp_newtype _ | Pexp_fun _ -> let xargs, xbody = Sugar.fun_ c.cmts xexp in let fmt_cstr, xbody = type_constr_and_body c xbody in @@ -2177,25 +2196,28 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) and args = fmt_fun_args c xargs in Params.Exp.box_fun_decl_args c.conf ~parens ~kw ~args ~annot:fmt_cstr in - hvbox_if (box || body_is_function) indent - (Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false - ~offset_closing_paren:(-2) - (hovbox 2 (intro $ str " ->" $ pre_body) $ fmt "@ " $ body) ) + pro + $ hvbox_if (box || body_is_function) indent + (Params.Exp.wrap c.conf ~parens ~disambiguate:true + ~fits_breaks:false ~offset_closing_paren:(-2) + (hovbox 2 (intro $ str " ->" $ pre_body) $ fmt "@ " $ body) ) | Pexp_function cs -> let indent = Params.Indent.function_ c.conf ~parens xexp in - Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false - @@ Params.Align.function_ c.conf ~parens ~ctx0 ~self:exp - @@ ( hvbox 2 - ( str "function" - $ fmt_extension_suffix c ext - $ fmt_attributes c pexp_attributes ) - $ break 1 indent - $ hvbox 0 (fmt_cases c ctx cs) ) + pro + $ Params.Exp.wrap c.conf ~parens ~disambiguate:true ~fits_breaks:false + @@ Params.Align.function_ c.conf ~parens ~ctx0 ~self:exp + @@ ( hvbox 2 + ( str "function" + $ fmt_extension_suffix c ext + $ fmt_attributes c pexp_attributes ) + $ break 1 indent + $ hvbox 0 (fmt_cases c ctx cs) ) | Pexp_ident {txt; loc} -> let outer_parens = has_attr && parens in - Cmts.fmt c loc - @@ wrap_if outer_parens "(" ")" - @@ (fmt_longident txt $ Cmts.fmt_within c loc $ fmt_atrs) + pro + $ Cmts.fmt c loc + @@ wrap_if outer_parens "(" ")" + @@ (fmt_longident txt $ Cmts.fmt_within c loc $ fmt_atrs) | Pexp_ifthenelse (if_branches, else_) -> let last_loc = match else_ with @@ -2216,66 +2238,72 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) List.rev ((None, sub_exp ~ctx x, []) :: List.rev with_conds) | None -> with_conds in - hvbox 0 - ( Params.Exp.wrap c.conf ~parens:(parens || has_attr) - (hvbox 0 - (list_fl cnd_exps - (fun ~first ~last (xcond, xbch, pexp_attributes) -> - let symbol_parens = Exp.is_symbol xbch.ast in - let parens_bch = parenze_exp xbch && not symbol_parens in - let parens_exp = false in - let p = - Params.get_if_then_else c.conf ~first ~last ~parens_bch - ~parens_prev_bch:!parens_prev_bch ~xcond ~xbch - ~expr_loc:pexp_loc - ~fmt_extension_suffix: - (Option.map ext ~f:(fun _ -> - fmt_extension_suffix c ext ) ) - ~fmt_attributes: - (fmt_attributes c ~pre:Blank pexp_attributes) - ~fmt_cond:(fmt_expression c) - in - parens_prev_bch := parens_bch ; - p.box_branch - ( p.cond - $ p.box_keyword_and_expr - ( p.branch_pro - $ p.wrap_parens - ( fmt_expression c ?box:p.box_expr - ~parens:parens_exp ?pro:p.expr_pro - ?eol:p.expr_eol p.branch_expr - $ p.break_end_branch ) ) ) - $ fmt_if_k (not last) p.space_between_branches ) ) ) - $ fmt_atrs ) + pro + $ hvbox 0 + ( Params.Exp.wrap c.conf ~parens:(parens || has_attr) + (hvbox 0 + (list_fl cnd_exps + (fun ~first ~last (xcond, xbch, pexp_attributes) -> + let symbol_parens = Exp.is_symbol xbch.ast in + let parens_bch = + parenze_exp xbch && not symbol_parens + in + let parens_exp = false in + let p = + Params.get_if_then_else c.conf ~first ~last + ~parens_bch ~parens_prev_bch:!parens_prev_bch + ~xcond ~xbch ~expr_loc:pexp_loc + ~fmt_extension_suffix: + (Option.map ext ~f:(fun _ -> + fmt_extension_suffix c ext ) ) + ~fmt_attributes: + (fmt_attributes c ~pre:Blank pexp_attributes) + ~fmt_cond:(fmt_expression c) + in + parens_prev_bch := parens_bch ; + p.box_branch + ( p.cond + $ p.box_keyword_and_expr + ( p.branch_pro + $ p.wrap_parens + ( fmt_expression c ?box:p.box_expr + ~parens:parens_exp ?pro:p.expr_pro + ?eol:p.expr_eol p.branch_expr + $ p.break_end_branch ) ) ) + $ fmt_if_k (not last) p.space_between_branches ) ) ) + $ fmt_atrs ) | Pexp_let (lbs, body) -> let bindings = Sugar.Let_binding.of_let_bindings c.cmts ~ctx lbs.pvbs_bindings in let fmt_expr = fmt_expression c (sub_exp ~ctx body) in let ext = lbs.pvbs_extension in - fmt_let_bindings c ?ext ~parens ~fmt_atrs ~fmt_expr ~has_attr - lbs.pvbs_rec bindings body + pro + $ fmt_let_bindings c ?ext ~parens ~fmt_atrs ~fmt_expr ~has_attr + lbs.pvbs_rec bindings body | Pexp_letop {let_; ands; body} -> let bd = Sugar.Let_binding.of_binding_ops c.cmts ~ctx (let_ :: ands) in let fmt_expr = fmt_expression c (sub_exp ~ctx body) in - fmt_let_bindings c ?ext ~parens ~fmt_atrs ~fmt_expr ~has_attr - Nonrecursive bd body + pro + $ fmt_let_bindings c ?ext ~parens ~fmt_atrs ~fmt_expr ~has_attr + Nonrecursive bd body | Pexp_letexception (ext_cstr, exp) -> let pre = str "let exception" $ fmt_extension_suffix c ext $ fmt "@ " in - hvbox 0 - ( Params.parens_if - (parens || not (List.is_empty pexp_attributes)) - c.conf - ( hvbox 0 - ( hvbox 2 - (hvbox 2 - (pre $ fmt_extension_constructor c ctx ext_cstr) ) - $ fmt "@ in" ) - $ fmt "@;<1000 0>" - $ fmt_expression c (sub_exp ~ctx exp) ) - $ fmt_atrs ) + pro + $ hvbox 0 + ( Params.parens_if + (parens || not (List.is_empty pexp_attributes)) + c.conf + ( hvbox 0 + ( hvbox 2 + (hvbox 2 + (pre $ fmt_extension_constructor c ctx ext_cstr) ) + $ fmt "@ in" ) + $ fmt "@;<1000 0>" + $ fmt_expression c (sub_exp ~ctx exp) ) + $ fmt_atrs ) | Pexp_letmodule (name, args, pmod, exp) -> let keyword = "let module" in let xbody = sub_mod ~ctx pmod in @@ -2294,18 +2322,19 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) | Pmod_apply _ | Pmod_apply_unit _ -> true | _ -> false in - hvbox 0 - ( Params.parens_if - (parens || not (List.is_empty pexp_attributes)) - c.conf - ( hvbox 2 - (fmt_module c ctx keyword ~eqty:":" name args (Some xbody) - xmty - ~attrs:(Ast_helper.Attr.ext_attrs ?ext ()) - ~epi:(str "in") ~can_sparse ~rec_flag:false ) - $ fmt "@;<1000 0>" - $ fmt_expression c (sub_exp ~ctx exp) ) - $ fmt_atrs ) + pro + $ hvbox 0 + ( Params.parens_if + (parens || not (List.is_empty pexp_attributes)) + c.conf + ( hvbox 2 + (fmt_module c ctx keyword ~eqty:":" name args (Some xbody) + xmty + ~attrs:(Ast_helper.Attr.ext_attrs ?ext ()) + ~epi:(str "in") ~can_sparse ~rec_flag:false ) + $ fmt "@;<1000 0>" + $ fmt_expression c (sub_exp ~ctx exp) ) + $ fmt_atrs ) | Pexp_open (lid, e0) -> let can_skip_parens = (not (Cmts.has_before c.cmts e0.pexp_loc)) @@ -2321,16 +2350,17 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) in let outer_parens = has_attr && parens in let inner_parens = not can_skip_parens in - hovbox 0 - (Params.parens_if outer_parens c.conf - ( hvbox 0 - ( hvbox 0 - ( fmt_longident_loc c lid $ str "." - $ fmt_if inner_parens "(" ) - $ fmt "@;<0 2>" - $ fmt_expression c (sub_exp ~ctx e0) - $ fmt_if_k inner_parens (closing_paren c) ) - $ fmt_atrs ) ) + pro + $ hovbox 0 + (Params.parens_if outer_parens c.conf + ( hvbox 0 + ( hvbox 0 + ( fmt_longident_loc c lid $ str "." + $ fmt_if inner_parens "(" ) + $ fmt "@;<0 2>" + $ fmt_expression c (sub_exp ~ctx e0) + $ fmt_if_k inner_parens (closing_paren c) ) + $ fmt_atrs ) ) | Pexp_letopen ( { popen_override= flag ; popen_expr @@ -2340,28 +2370,29 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) let override = is_override flag in let outer_parens = has_attr && parens in let inner_parens = has_attr || parens in - hovbox 0 - (Params.Exp.wrap c.conf ~parens:outer_parens ~fits_breaks:false - ( hvbox 0 - (Params.Exp.wrap c.conf ~parens:inner_parens - ~fits_breaks:false - (vbox 0 - ( hvbox 0 - ( fmt_module_statement c ~attributes - ~keyword: - ( hvbox 0 - ( str "let" $ break 1 0 - $ Cmts.fmt_before c popen_loc - $ fmt_or override "open!" "open" - $ opt ext (fun _ -> fmt_if override " ") - $ fmt_extension_suffix c ext ) - $ break 1 0 ) - (sub_mod ~ctx popen_expr) - $ Cmts.fmt_after c popen_loc - $ str " in" ) - $ break 1000 0 - $ fmt_expression c (sub_exp ~ctx e0) ) ) ) - $ fmt_atrs ) ) + pro + $ hovbox 0 + (Params.Exp.wrap c.conf ~parens:outer_parens ~fits_breaks:false + ( hvbox 0 + (Params.Exp.wrap c.conf ~parens:inner_parens + ~fits_breaks:false + (vbox 0 + ( hvbox 0 + ( fmt_module_statement c ~attributes + ~keyword: + ( hvbox 0 + ( str "let" $ break 1 0 + $ Cmts.fmt_before c popen_loc + $ fmt_or override "open!" "open" + $ opt ext (fun _ -> fmt_if override " ") + $ fmt_extension_suffix c ext ) + $ break 1 0 ) + (sub_mod ~ctx popen_expr) + $ Cmts.fmt_after c popen_loc + $ str " in" ) + $ break 1000 0 + $ fmt_expression c (sub_exp ~ctx e0) ) ) ) + $ fmt_atrs ) ) | Pexp_try (e0, [{pc_lhs; pc_guard; pc_rhs}]) when Poly.( c.conf.fmt_opts.single_case.v = `Compact @@ -2374,36 +2405,39 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) if c.conf.fmt_opts.leading_nested_match_parens.v then (false, None) else (parenze_exp xpc_rhs, Some false) in - Params.Exp.wrap c.conf ~parens ~disambiguate:true - (hvbox 2 - ( hvbox 0 - ( str "try" - $ fmt_extension_suffix c ext - $ fmt_attributes c pexp_attributes - $ fmt "@;<1 2>" - $ fmt_expression c (sub_exp ~ctx e0) ) - $ break 1 (-2) - $ hvbox 0 - ( hvbox 0 - ( fmt "with@ " $ leading_cmt - $ hvbox 0 - ( fmt_pattern c ~pro:(if_newline "| ") - (sub_pat ~ctx pc_lhs) - $ opt pc_guard (fun g -> - fmt "@ when " - $ fmt_expression c (sub_exp ~ctx g) ) - $ fmt "@ ->" $ fmt_if parens_here " (" ) ) - $ fmt "@;<1 2>" - $ cbox 0 (fmt_expression c ?parens:parens_for_exp xpc_rhs) ) - $ fmt_if parens_here - ( match c.conf.fmt_opts.indicate_multiline_delimiters.v with - | `No -> ")" - | `Space -> " )" - | `Closing_on_separate_line -> "@;<1000 -2>)" ) ) ) + pro + $ Params.Exp.wrap c.conf ~parens ~disambiguate:true + (hvbox 2 + ( hvbox 0 + ( str "try" + $ fmt_extension_suffix c ext + $ fmt_attributes c pexp_attributes + $ fmt "@;<1 2>" + $ fmt_expression c (sub_exp ~ctx e0) ) + $ break 1 (-2) + $ hvbox 0 + ( hvbox 0 + ( fmt "with@ " $ leading_cmt + $ hvbox 0 + ( fmt_pattern c ~pro:(if_newline "| ") + (sub_pat ~ctx pc_lhs) + $ opt pc_guard (fun g -> + fmt "@ when " + $ fmt_expression c (sub_exp ~ctx g) ) + $ fmt "@ ->" $ fmt_if parens_here " (" ) ) + $ fmt "@;<1 2>" + $ cbox 0 (fmt_expression c ?parens:parens_for_exp xpc_rhs) + ) + $ fmt_if parens_here + ( match c.conf.fmt_opts.indicate_multiline_delimiters.v with + | `No -> ")" + | `Space -> " )" + | `Closing_on_separate_line -> "@;<1000 -2>)" ) ) ) | Pexp_match (e0, cs) -> - fmt_match c ?epi ~parens ?ext ctx xexp cs e0 "match" - | Pexp_try (e0, cs) -> fmt_match c ?epi ~parens ?ext ctx xexp cs e0 "try" + fmt_match c ~pro ~parens ?ext ctx xexp cs e0 "match" + | Pexp_try (e0, cs) -> fmt_match c ~pro ~parens ?ext ctx xexp cs e0 "try" | Pexp_pack (me, pt) -> + let outer_pro = pro in let outer_parens = parens && has_attr in let inner_parens = true in let blk = fmt_module_expr c (sub_mod ~ctx me) in @@ -2432,9 +2466,10 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) $ fmt_package_type c ctx cnstrs ) | None -> m in - hvbox 0 - (Params.parens_if outer_parens c.conf - (compose_module ~pro ~epi blk ~f:fmt_mod $ fmt_atrs) ) + outer_pro + $ hvbox 0 + (Params.parens_if outer_parens c.conf + (compose_module ~pro ~epi blk ~f:fmt_mod $ fmt_atrs) ) | Pexp_record (flds, default) -> let fmt_field (lid, (typ1, typ2), exp) = let typ1 = Option.map typ1 ~f:(sub_typ ~ctx) in @@ -2456,13 +2491,15 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) fmt_elements_collection c p1 last_loc pexp_loc fmt_field flds ~pro:(break 1 2) in - hvbox_if has_attr 0 - ( p1.box - ( opt default (fun d -> - hvbox 2 (fmt_expression c (sub_exp ~ctx d) $ fmt "@;<1 -2>") - $ str "with" $ p2.break_after_with ) - $ fmt_fields ) - $ fmt_atrs ) + pro + $ hvbox_if has_attr 0 + ( p1.box + ( opt default (fun d -> + hvbox 2 + (fmt_expression c (sub_exp ~ctx d) $ fmt "@;<1 -2>") + $ str "with" $ p2.break_after_with ) + $ fmt_fields ) + $ fmt_atrs ) | Pexp_extension ( ext , PStr @@ -2474,17 +2511,22 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) ; pstr_loc= _ } ] ) when Source.extension_using_sugar ~name:ext ~payload:e1.pexp_loc && List.length (Sugar.sequence c.cmts xexp) > 1 -> - fmt_sequence ~has_attr c parens (expression_width c) xexp fmt_atrs ~ext + pro + $ fmt_sequence ~has_attr c parens (expression_width c) xexp fmt_atrs + ~ext | Pexp_sequence _ -> - fmt_sequence ~has_attr c parens (expression_width c) xexp fmt_atrs ?ext + pro + $ fmt_sequence ~has_attr c parens (expression_width c) xexp fmt_atrs + ?ext | Pexp_setfield (e1, lid, e2) -> - hvbox 0 - (Params.Exp.wrap c.conf ~parens - ( Params.parens_if has_attr c.conf - ( fmt_expression c (sub_exp ~ctx e1) - $ str "." $ fmt_longident_loc c lid $ fmt_assign_arrow c - $ fmt_expression c (sub_exp ~ctx e2) ) - $ fmt_atrs ) ) + pro + $ hvbox 0 + (Params.Exp.wrap c.conf ~parens + ( Params.parens_if has_attr c.conf + ( fmt_expression c (sub_exp ~ctx e1) + $ str "." $ fmt_longident_loc c lid $ fmt_assign_arrow c + $ fmt_expression c (sub_exp ~ctx e2) ) + $ fmt_atrs ) ) | Pexp_tuple es -> let parens = match xexp.ctx with @@ -2508,22 +2550,24 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) in let outer_wrap = has_attr && parens in let inner_wrap = has_attr || parens in - hvbox_if outer_wrap 0 - (Params.parens_if outer_wrap c.conf - ( hvbox 0 - (Params.wrap_tuple ~parens:inner_wrap ~no_parens_if_break - c.conf - (list es (Params.comma_sep c.conf) - (sub_exp ~ctx >> fmt_expression c) ) ) - $ fmt_atrs ) ) + pro + $ hvbox_if outer_wrap 0 + (Params.parens_if outer_wrap c.conf + ( hvbox 0 + (Params.wrap_tuple ~parens:inner_wrap ~no_parens_if_break + c.conf + (list es (Params.comma_sep c.conf) + (sub_exp ~ctx >> fmt_expression c) ) ) + $ fmt_atrs ) ) | Pexp_lazy e -> - hvbox 2 - (Params.Exp.wrap c.conf ~parens - ( str "lazy" - $ fmt_extension_suffix c ext - $ fmt "@ " - $ fmt_expression c (sub_exp ~ctx e) - $ fmt_atrs ) ) + pro + $ hvbox 2 + (Params.Exp.wrap c.conf ~parens + ( str "lazy" + $ fmt_extension_suffix c ext + $ fmt "@ " + $ fmt_expression c (sub_exp ~ctx e) + $ fmt_atrs ) ) | Pexp_extension ( ext , PStr @@ -2544,11 +2588,12 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) when Source.extension_using_sugar ~name:ext ~payload:e1.pexp_loc -> let outer_parens = has_attr && parens in let inner_parens = has_attr || parens in - hvbox 0 - (Params.parens_if outer_parens c.conf - ( fmt_expression c ~box ?eol ~parens:inner_parens ~ext - (sub_exp ~ctx:(Str str) e1) - $ fmt_atrs ) ) + pro + $ hvbox 0 + (Params.parens_if outer_parens c.conf + ( fmt_expression c ~box ?eol ~parens:inner_parens ~ext + (sub_exp ~ctx:(Str str) e1) + $ fmt_atrs ) ) | Pexp_extension ( ext , PStr @@ -2560,77 +2605,86 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) ; pstr_loc= _ } as str ) ] ) when List.is_empty pexp_attributes && Source.extension_using_sugar ~name:ext ~payload:e1.pexp_loc -> - hvbox 0 - ( fmt_expression c ~box ?eol ~parens ~ext (sub_exp ~ctx:(Str str) e1) - $ fmt_atrs ) + pro + $ hvbox 0 + ( fmt_expression c ~box ?eol ~parens ~ext + (sub_exp ~ctx:(Str str) e1) + $ fmt_atrs ) | Pexp_extension ext -> - hvbox 0 - (Params.Exp.wrap c.conf ~parens - ( hvbox c.conf.fmt_opts.extension_indent.v - (fmt_extension c ctx ext) - $ fmt_atrs ) ) + pro + $ hvbox 0 + (Params.Exp.wrap c.conf ~parens + ( hvbox c.conf.fmt_opts.extension_indent.v + (fmt_extension c ctx ext) + $ fmt_atrs ) ) | Pexp_for (p1, e1, e2, dir, e3) -> - hvbox 0 - (Params.Exp.wrap c.conf ~parens - ( hovbox 0 - ( hvbox 2 - ( hvbox 0 - ( str "for" - $ fmt_extension_suffix c ext - $ fmt "@;<1 2>" - $ hovbox 0 - ( fmt_pattern c (sub_pat ~ctx p1) - $ fmt "@ =@;<1 2>" - $ fmt_expression c (sub_exp ~ctx e1) - $ fmt_direction_flag dir - $ fmt_expression c (sub_exp ~ctx e2) ) - $ fmt "@;do" ) - $ fmt "@;<1000 0>" - $ fmt_expression c (sub_exp ~ctx e3) ) - $ fmt "@;<1000 0>done" ) - $ fmt_atrs ) ) + pro + $ hvbox 0 + (Params.Exp.wrap c.conf ~parens + ( hovbox 0 + ( hvbox 2 + ( hvbox 0 + ( str "for" + $ fmt_extension_suffix c ext + $ fmt "@;<1 2>" + $ hovbox 0 + ( fmt_pattern c (sub_pat ~ctx p1) + $ fmt "@ =@;<1 2>" + $ fmt_expression c (sub_exp ~ctx e1) + $ fmt_direction_flag dir + $ fmt_expression c (sub_exp ~ctx e2) ) + $ fmt "@;do" ) + $ fmt "@;<1000 0>" + $ fmt_expression c (sub_exp ~ctx e3) ) + $ fmt "@;<1000 0>done" ) + $ fmt_atrs ) ) | Pexp_coerce (e1, t1, t2) -> - hvbox 2 - (Params.parens_if (parens && has_attr) c.conf - ( wrap_fits_breaks ~space:false c.conf "(" ")" - ( fmt_expression c (sub_exp ~ctx e1) - $ opt t1 (fmt "@ : " >$ (sub_typ ~ctx >> fmt_core_type c)) - $ fmt "@ :> " - $ fmt_core_type c (sub_typ ~ctx t2) ) - $ fmt_atrs ) ) + pro + $ hvbox 2 + (Params.parens_if (parens && has_attr) c.conf + ( wrap_fits_breaks ~space:false c.conf "(" ")" + ( fmt_expression c (sub_exp ~ctx e1) + $ opt t1 (fmt "@ : " >$ (sub_typ ~ctx >> fmt_core_type c)) + $ fmt "@ :> " + $ fmt_core_type c (sub_typ ~ctx t2) ) + $ fmt_atrs ) ) | Pexp_while (e1, e2) -> - hvbox 0 - (Params.Exp.wrap c.conf ~parens - ( hovbox 0 - ( hvbox 2 - ( hvbox 0 - ( str "while" - $ fmt_extension_suffix c ext - $ fmt "@;<1 2>" - $ fmt_expression c (sub_exp ~ctx e1) - $ fmt "@;do" ) - $ fmt "@;<1000 0>" - $ fmt_expression c (sub_exp ~ctx e2) ) - $ fmt "@;<1000 0>done" ) - $ fmt_atrs ) ) - | Pexp_unreachable -> str "." + pro + $ hvbox 0 + (Params.Exp.wrap c.conf ~parens + ( hovbox 0 + ( hvbox 2 + ( hvbox 0 + ( str "while" + $ fmt_extension_suffix c ext + $ fmt "@;<1 2>" + $ fmt_expression c (sub_exp ~ctx e1) + $ fmt "@;do" ) + $ fmt "@;<1000 0>" + $ fmt_expression c (sub_exp ~ctx e2) ) + $ fmt "@;<1000 0>done" ) + $ fmt_atrs ) ) + | Pexp_unreachable -> pro $ str "." | Pexp_send (exp, meth) -> - hvbox 2 - (Params.parens_if parens c.conf - ( fmt_expression c (sub_exp ~ctx exp) - $ fmt "@,#" $ fmt_str_loc c meth $ fmt_atrs ) ) + pro + $ hvbox 2 + (Params.parens_if parens c.conf + ( fmt_expression c (sub_exp ~ctx exp) + $ fmt "@,#" $ fmt_str_loc c meth $ fmt_atrs ) ) | Pexp_new {txt; loc} -> - Cmts.fmt c loc - @@ hvbox 2 - (Params.parens_if parens c.conf - ( str "new" - $ fmt_extension_suffix c ext - $ fmt "@ " $ fmt_longident txt $ fmt_atrs ) ) + pro + $ Cmts.fmt c loc + @@ hvbox 2 + (Params.parens_if parens c.conf + ( str "new" + $ fmt_extension_suffix c ext + $ fmt "@ " $ fmt_longident txt $ fmt_atrs ) ) | Pexp_object {pcstr_self; pcstr_fields} -> - hvbox 0 - (Params.parens_if parens c.conf - ( fmt_class_structure c ~ctx ?ext pcstr_self pcstr_fields - $ fmt_atrs ) ) + pro + $ hvbox 0 + (Params.parens_if parens c.conf + ( fmt_class_structure c ~ctx ?ext pcstr_self pcstr_fields + $ fmt_atrs ) ) | Pexp_override l -> ( let fmt_field ({txt; loc}, f) = let eol = fmt "@;<1 3>" in @@ -2647,26 +2701,29 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) in match l with | [] -> - Params.parens_if parens c.conf - (wrap "{<" ">}" (Cmts.fmt_within c pexp_loc) $ fmt_atrs) + pro + $ Params.parens_if parens c.conf + (wrap "{<" ">}" (Cmts.fmt_within c pexp_loc) $ fmt_atrs) | _ -> - hvbox 0 - (Params.parens_if parens c.conf - ( wrap_fits_breaks ~space:false c.conf "{<" ">}" - (list l "@;<0 1>; " fmt_field) - $ fmt_atrs ) ) ) + pro + $ hvbox 0 + (Params.parens_if parens c.conf + ( wrap_fits_breaks ~space:false c.conf "{<" ">}" + (list l "@;<0 1>; " fmt_field) + $ fmt_atrs ) ) ) | Pexp_setinstvar (name, expr) -> - hvbox 0 - (Params.Exp.wrap c.conf ~parens - ( Params.parens_if has_attr c.conf - ( fmt_str_loc c name $ fmt_assign_arrow c - $ hvbox 2 (fmt_expression c (sub_exp ~ctx expr)) ) - $ fmt_atrs ) ) + pro + $ hvbox 0 + (Params.Exp.wrap c.conf ~parens + ( Params.parens_if has_attr c.conf + ( fmt_str_loc c name $ fmt_assign_arrow c + $ hvbox 2 (fmt_expression c (sub_exp ~ctx expr)) ) + $ fmt_atrs ) ) | Pexp_indexop_access x -> - fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x + pro $ fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x | Pexp_poly _ -> impossible "only used for methods, handled during method formatting" - | Pexp_hole -> hvbox 0 (fmt_hole () $ fmt_atrs) + | Pexp_hole -> pro $ hvbox 0 (fmt_hole () $ fmt_atrs) | Pexp_beginend e -> let wrap_beginend k = let opn = str "begin" $ fmt_extension_suffix c ext @@ -2674,13 +2731,15 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0) hvbox 0 (wrap_k opn cls (wrap_k (break 1 2) (break 1000 0) k) $ fmt_atrs) in - wrap_beginend - @@ fmt_expression c ~box ?pro ?epi ?eol ~parens:false ~indent_wrap ?ext - (sub_exp ~ctx e) + pro + $ wrap_beginend + (fmt_expression c ~box ?eol ~parens:false ~indent_wrap ?ext + (sub_exp ~ctx e) ) | Pexp_parens e -> - hvbox 0 - @@ fmt_expression c ~box ?pro ?epi ?eol ~parens:true ~indent_wrap ?ext - (sub_exp ~ctx e) + pro + $ hvbox 0 + (fmt_expression c ~box ?eol ~parens:true ~indent_wrap ?ext + (sub_exp ~ctx e) ) $ fmt_atrs and fmt_let_bindings c ?ext ~parens ~has_attr ~fmt_atrs ~fmt_expr rec_flag diff --git a/test/passing/dune.inc b/test/passing/dune.inc index 18598598e6..172e04e603 100644 --- a/test/passing/dune.inc +++ b/test/passing/dune.inc @@ -4114,13 +4114,31 @@ (package ocamlformat) (action (diff tests/obuild.ml.err obuild.ml.stderr))) +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to ocp_indent_compat-break_colon_after.ml.stdout + (with-stderr-to ocp_indent_compat-break_colon_after.ml.stderr + (run %{bin:ocamlformat} --margin-check --ocp-indent-compat --break-colon=after %{dep:tests/ocp_indent_compat.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/ocp_indent_compat-break_colon_after.ml.ref ocp_indent_compat-break_colon_after.ml.stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/ocp_indent_compat-break_colon_after.ml.err ocp_indent_compat-break_colon_after.ml.stderr))) + (rule (deps tests/.ocamlformat ) (package ocamlformat) (action (with-stdout-to ocp_indent_compat.ml.stdout (with-stderr-to ocp_indent_compat.ml.stderr - (run %{bin:ocamlformat} --margin-check %{dep:tests/ocp_indent_compat.ml}))))) + (run %{bin:ocamlformat} --margin-check --ocp-indent-compat --break-colon=before %{dep:tests/ocp_indent_compat.ml}))))) (rule (alias runtest) diff --git a/test/passing/tests/ocp_indent_compat-break_colon_after.ml.opts b/test/passing/tests/ocp_indent_compat-break_colon_after.ml.opts new file mode 100644 index 0000000000..4ebafbf051 --- /dev/null +++ b/test/passing/tests/ocp_indent_compat-break_colon_after.ml.opts @@ -0,0 +1,2 @@ +--ocp-indent-compat +--break-colon=after diff --git a/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref b/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref new file mode 100644 index 0000000000..633d0168dc --- /dev/null +++ b/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref @@ -0,0 +1,93 @@ +(* Bad: unboxing the function type *) +external i : (int -> float[@unboxed]) = "i" "i_nat" + +module type M = sig + val action : action + (** Formatting action: input type and source, and output destination. *) + + val doc_atrs : + (string Location.loc * payload) list + -> (string Location.loc * bool) list option + * (string Location.loc * payload) list + + val transl_modtype_longident + (* from Typemod *) : + (Location.t -> Env.t -> Longident.t -> Path.t) ref + + val transl_modtype_longident + (* foooooooooo fooooooooooooo foooooooooooo foooooooooooooo + foooooooooooooo foooooooooooo *) : + (Location.t -> Env.t -> Longident.t -> Path.t) ref + + val imported_sets_of_closures_table : + Simple_value_approx.function_declarations option Set_of_closures_id.Tbl.t + + type 'a option_decl = + names:string list + -> doc:string + -> section:[`Formatting | `Operational] + -> ?allow_inline:bool + -> (config -> 'a -> config) + -> (config -> 'a) + -> 'a t + + val select : + (* The fsevents context *) + env + -> (* Additional file descriptor to select for reading *) + ?read_fdl:fd_select list + -> (* Additional file descriptor to select for writing *) + ?write_fdl:fd_select list + -> (* Timeout...like Unix.select *) + timeout:float + -> (* The callback for file system events *) + (event list -> unit) + -> unit + + val f : + x:t + (** an extremely long comment about [x] that does not fit on the same + line with [x] *) + -> unit + + val f : + fooooooooooooooooo: + (fooooooooooooooo + -> fooooooooooooooooooo + -> foooooooooooooo + -> foooooooooooooo * fooooooooooooooooo + -> foooooooooooooooo ) + (** an extremely long comment about [x] that does not fit on the same + line with [x] *) + -> unit +end + +let ssmap : + (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) + = + () + +let ssmap : + (module MapT + with type key = string + and type data = string + and type map = SSMap.map ) + -> unit + = + () + +let long_function_name : + type a. a long_long_type -> a -> a -> a -> wrap_wrap_wrap -> unit + = + fun () -> () + +let add_edge target dep = + if target <> dep then ( + Hashtbl.replace edges dep + (target :: (try Hashtbl.find edges dep with Not_found -> [])) ; + Hashtbl.replace edge_count target + (1 + try Hashtbl.find edge_count target with Not_found -> 0) ; + if not (Hashtbl.mem edge_count dep) then Hashtbl.add edge_count dep 0 ) diff --git a/test/passing/tests/ocp_indent_compat.ml b/test/passing/tests/ocp_indent_compat.ml index ea9f32eafb..224fa0e407 100644 --- a/test/passing/tests/ocp_indent_compat.ml +++ b/test/passing/tests/ocp_indent_compat.ml @@ -1,7 +1,3 @@ -[@@@ocamlformat "ocp-indent-compat=true"] - -[@@@ocamlformat "break-colon=before"] - (* Bad: unboxing the function type *) external i : (int -> float[@unboxed]) = "i" "i_nat" @@ -89,64 +85,10 @@ let long_function_name = fun () -> () -[@@@ocamlformat "ocp-indent-compat=false"] - -[@@@ocamlformat "break-colon=after"] - -module type M = sig - val transl_modtype_longident (* from Typemod *) : - (Location.t -> Env.t -> Longident.t -> Path.t) ref - - val transl_modtype_longident - (* foooooooooo fooooooooooooo foooooooooooo foooooooooooooo - foooooooooooooo foooooooooooo *) : - (Location.t -> Env.t -> Longident.t -> Path.t) ref - - val imported_sets_of_closures_table : - Simple_value_approx.function_declarations option Set_of_closures_id.Tbl.t - - val select : - (* The fsevents context *) - env - -> (* Additional file descriptor to select for reading *) - ?read_fdl:fd_select list - -> (* Additional file descriptor to select for writing *) - ?write_fdl:fd_select list - -> (* Timeout...like Unix.select *) - timeout:float - -> (* The callback for file system events *) - (event list -> unit) - -> unit - - val f : - x:t - (** an extremely long comment about [x] that does not fit on the - same line with [x] *) - -> unit - - val f : - fooooooooooooooooo: - ( fooooooooooooooo - -> fooooooooooooooooooo - -> foooooooooooooo - -> foooooooooooooo * fooooooooooooooooo - -> foooooooooooooooo ) - (** an extremely long comment about [x] that does not fit on the - same line with [x] *) - -> unit -end - -let array_fold_transf (f : numbering -> 'a -> numbering * 'b) n (a : 'a array) - : numbering * 'b array = - match Array.length a with 0 -> (n, [||]) | 1 -> x - -let to_clambda_function (id, (function_decl : Flambda.function_declaration)) - : Clambda.ufunction = - (* All that we need in the environment, for translating one closure from a - closed set of closures, is the substitutions for variables bound to the - various closures in the set. Such closures will always be ... *) - x - -let long_function_name : - type a. a long_long_type -> a -> a -> a -> wrap_wrap_wrap -> unit = - fun () -> () +let add_edge target dep = + if target <> dep then ( + Hashtbl.replace edges dep + (target :: (try Hashtbl.find edges dep with Not_found -> [])) ; + Hashtbl.replace edge_count target + (1 + try Hashtbl.find edge_count target with Not_found -> 0) ; + if not (Hashtbl.mem edge_count dep) then Hashtbl.add edge_count dep 0 ) diff --git a/test/passing/tests/ocp_indent_compat.ml.err b/test/passing/tests/ocp_indent_compat.ml.err index 6faa1c0e72..e69de29bb2 100644 --- a/test/passing/tests/ocp_indent_compat.ml.err +++ b/test/passing/tests/ocp_indent_compat.ml.err @@ -1 +0,0 @@ -Warning: tests/ocp_indent_compat.ml:138 exceeds the margin diff --git a/test/passing/tests/ocp_indent_compat.ml.opts b/test/passing/tests/ocp_indent_compat.ml.opts new file mode 100644 index 0000000000..7b22536b8d --- /dev/null +++ b/test/passing/tests/ocp_indent_compat.ml.opts @@ -0,0 +1,2 @@ +--ocp-indent-compat +--break-colon=before From b790cc467715fb82176037ca92a637e24273837d Mon Sep 17 00:00:00 2001 From: hhugo Date: Mon, 9 Oct 2023 09:20:38 +0200 Subject: [PATCH 12/19] --no-comment-check ignores floating doc comments (#2456) This fixes a regression introduced in #1672 making --no-comment-check less useful. --- lib/Normalize_std_ast.ml | 40 ++++++++++++++++++++++++++++++++++ lib/Std_ast.ml | 7 +++++- test/passing/dune.inc | 18 +++++++++++++++ test/passing/tests/w50.ml | 20 +++++++++++++++++ test/passing/tests/w50.ml.opts | 1 + test/passing/tests/w50.ml.ref | 20 +++++++++++++++++ 6 files changed, 105 insertions(+), 1 deletion(-) create mode 100644 test/passing/tests/w50.ml create mode 100644 test/passing/tests/w50.ml.opts create mode 100644 test/passing/tests/w50.ml.ref diff --git a/lib/Normalize_std_ast.ml b/lib/Normalize_std_ast.ml index 7651e0d2ec..a037bc8a89 100644 --- a/lib/Normalize_std_ast.ml +++ b/lib/Normalize_std_ast.ml @@ -152,10 +152,50 @@ let make_mapper conf ~ignore_doc_comments = let typ = {typ with ptyp_loc_stack= []} in Ast_mapper.default_mapper.typ m typ in + let structure = + if ignore_doc_comments then fun (m : Ast_mapper.mapper) l -> + List.filter l ~f:(function + | {pstr_desc= Pstr_attribute a; _} -> not (is_doc a) + | _ -> true ) + |> Ast_mapper.default_mapper.structure m + else Ast_mapper.default_mapper.structure + in + let signature = + if ignore_doc_comments then fun (m : Ast_mapper.mapper) l -> + List.filter l ~f:(function + | {psig_desc= Psig_attribute a; _} -> not (is_doc a) + | _ -> true ) + |> Ast_mapper.default_mapper.signature m + else Ast_mapper.default_mapper.signature + in + let class_structure = + if ignore_doc_comments then fun (m : Ast_mapper.mapper) x -> + let pcstr_fields = + List.filter x.pcstr_fields ~f:(function + | {pcf_desc= Pcf_attribute a; _} -> not (is_doc a) + | _ -> true ) + in + Ast_mapper.default_mapper.class_structure m {x with pcstr_fields} + else Ast_mapper.default_mapper.class_structure + in + let class_signature = + if ignore_doc_comments then fun (m : Ast_mapper.mapper) x -> + let pcsig_fields = + List.filter x.pcsig_fields ~f:(function + | {pctf_desc= Pctf_attribute a; _} -> not (is_doc a) + | _ -> true ) + in + Ast_mapper.default_mapper.class_signature m {x with pcsig_fields} + else Ast_mapper.default_mapper.class_signature + in { Ast_mapper.default_mapper with location ; attribute ; attributes + ; structure + ; signature + ; class_signature + ; class_structure ; expr ; pat ; typ } diff --git a/lib/Std_ast.ml b/lib/Std_ast.ml index e556450fdd..f1c04ab441 100644 --- a/lib/Std_ast.ml +++ b/lib/Std_ast.ml @@ -43,7 +43,12 @@ let map (type a) (x : a t) (m : Ast_mapper.mapper) : a -> a = match x with | Structure -> m.structure m | Signature -> m.signature m - | Use_file -> List.map ~f:(m.toplevel_phrase m) + | Use_file -> + List.filter_map ~f:(fun x -> + match m.toplevel_phrase m x with + | Ptop_def [] -> None + | Ptop_def _ as x -> Some x + | Ptop_dir _ as x -> Some x ) | Core_type -> m.typ m | Module_type -> m.module_type m | Expression -> m.expr m diff --git a/test/passing/dune.inc b/test/passing/dune.inc index 172e04e603..0db3020328 100644 --- a/test/passing/dune.inc +++ b/test/passing/dune.inc @@ -5401,6 +5401,24 @@ (package ocamlformat) (action (diff tests/verbose1.ml.err verbose1.ml.stderr))) +(rule + (deps tests/.ocamlformat ) + (package ocamlformat) + (action + (with-stdout-to w50.ml.stdout + (with-stderr-to w50.ml.stderr + (run %{bin:ocamlformat} --margin-check --no-comment-check -q --max-iters=3 %{dep:tests/w50.ml}))))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/w50.ml.ref w50.ml.stdout))) + +(rule + (alias runtest) + (package ocamlformat) + (action (diff tests/w50.ml.err w50.ml.stderr))) + (rule (deps tests/.ocamlformat ) (enabled_if (<> %{os_type} Win32)) diff --git a/test/passing/tests/w50.ml b/test/passing/tests/w50.ml new file mode 100644 index 0000000000..8cc9c6346c --- /dev/null +++ b/test/passing/tests/w50.ml @@ -0,0 +1,20 @@ +(* When using [--no-comment-check] (to format code despite warning 50), + We should not complain if doc-comments start appearing in the AST. +*) + +module type T = sig +val test_raises_some_exc : ('a -> 'b) -> 'a -> bool;; +(** AAAA *) + +val test_raises_this_exc : exn -> ('a -> 'b) -> 'a -> bool;; +(** BBBB *) +end + +module T = struct + +let test_raises_some_exc = 2;; +(** CCCC *) + +let test_raises_this_exc = 3;; +(** DDDD *) +end diff --git a/test/passing/tests/w50.ml.opts b/test/passing/tests/w50.ml.opts new file mode 100644 index 0000000000..8d4d0f6b48 --- /dev/null +++ b/test/passing/tests/w50.ml.opts @@ -0,0 +1 @@ +--no-comment-check -q --max-iters=3 \ No newline at end of file diff --git a/test/passing/tests/w50.ml.ref b/test/passing/tests/w50.ml.ref new file mode 100644 index 0000000000..26ecf36099 --- /dev/null +++ b/test/passing/tests/w50.ml.ref @@ -0,0 +1,20 @@ +(* When using [--no-comment-check] (to format code despite warning 50), We + should not complain if doc-comments start appearing in the AST. *) + +module type T = sig + val test_raises_some_exc : ('a -> 'b) -> 'a -> bool + + (** AAAA *) + + val test_raises_this_exc : exn -> ('a -> 'b) -> 'a -> bool + (** BBBB *) +end + +module T = struct + let test_raises_some_exc = 2 + + (** CCCC *) + + (** DDDD *) + let test_raises_this_exc = 3 +end From 5f5a541b2c67f1b3055c25a7422a760755274ab3 Mon Sep 17 00:00:00 2001 From: Thomas Del Vecchio <127883551+tdelvecchio-jsc@users.noreply.github.com> Date: Mon, 9 Oct 2023 22:57:48 -0400 Subject: [PATCH 13/19] Fixed bug with attributes on sub-expressions of infix operators. (#2459) --- CHANGES.md | 1 + lib/Sugar.ml | 13 +++++++++---- test/passing/tests/comments.ml | 4 ++++ test/passing/tests/comments.ml.ref | 4 ++++ 4 files changed, 18 insertions(+), 4 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 9e078cf01f..a2cc1ff512 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -17,6 +17,7 @@ profile. This started with version 0.26.0. - Fix extension-point spacing in structures (#2450, @Julow) - \* Consistent break after string constant argument (#2453, @Julow) - Fix invalid syntax generated with `ocp-indent-compat` (#2445, @Julow) +- Fixed bug with attributes on sub-expressions of infix operators (#2459, @tdelvecchio-jsc) ## 0.26.1 (2023-09-15) diff --git a/lib/Sugar.ml b/lib/Sugar.ml index 7e39c8d8b9..fb3c8f2b3f 100644 --- a/lib/Sugar.ml +++ b/lib/Sugar.ml @@ -76,9 +76,13 @@ let cl_fun ?(will_keep_first_ast_node = true) cmts xexp = module Exp = struct let infix cmts prec xexp = let assoc = Option.value_map prec ~default:Assoc.Non ~f:Assoc.of_prec in - let rec infix_ ?(relocate = true) xop xexp = + let rec infix_ ?(child_expr = true) xop xexp = let ctx = Exp xexp.ast in match (assoc, xexp.ast) with + | _, {pexp_attributes= _ :: _; _} when child_expr -> + (* Avoid dropping attributes on child expressions, e.g. [(a + b) + [@attr] + c] *) + [(xop, xexp)] | ( Left , {pexp_desc= Pexp_infix ({txt= op; loc}, e1, e2); pexp_loc= src; _} ) @@ -90,7 +94,8 @@ module Exp = struct | (None, {ast= {pexp_loc; _}; _}) :: _ -> pexp_loc | _ -> loc in - if relocate then Cmts.relocate cmts ~src ~before ~after:e2.pexp_loc ; + if child_expr then + Cmts.relocate cmts ~src ~before ~after:e2.pexp_loc ; op_args1 @ [(Some {txt= op; loc}, sub_exp ~ctx e2)] | ( Right , {pexp_desc= Pexp_infix ({txt= op; loc}, e1, e2); pexp_loc= src; _} @@ -105,11 +110,11 @@ module Exp = struct | Some (_, {ast= {pexp_loc; _}; _}) -> pexp_loc | None -> e1.pexp_loc in - if relocate then Cmts.relocate cmts ~src ~before ~after ; + if child_expr then Cmts.relocate cmts ~src ~before ~after ; (xop, sub_exp ~ctx e1) :: op_args2 | _ -> [(xop, xexp)] in - infix_ None ~relocate:false xexp + infix_ None ~child_expr:false xexp end let sequence cmts xexp = diff --git a/test/passing/tests/comments.ml b/test/passing/tests/comments.ml index ed4f0965cc..f6fa2146e7 100644 --- a/test/passing/tests/comments.ml +++ b/test/passing/tests/comments.ml @@ -311,3 +311,7 @@ type a = b (* a *) as (* b *) 'c (* c *) type t = { (* comment before mutable *) mutable (* really long comment that doesn't fit on the same line as other stuff *) x : int } + +let _ = (x + y) [@attr] + z + +let _ = x ^ (y ^ z) [@attr] diff --git a/test/passing/tests/comments.ml.ref b/test/passing/tests/comments.ml.ref index bfd372971a..548fdc173f 100644 --- a/test/passing/tests/comments.ml.ref +++ b/test/passing/tests/comments.ml.ref @@ -420,3 +420,7 @@ type t = stuff *) x: int } + +let _ = (x + y) [@attr] + z + +let _ = x ^ (y ^ z) [@attr] From 8f8c14f460e6e242efc872849d7ed13e4134fb77 Mon Sep 17 00:00:00 2001 From: Thomas Del Vecchio <127883551+tdelvecchio-jsc@users.noreply.github.com> Date: Mon, 9 Oct 2023 23:14:56 -0400 Subject: [PATCH 14/19] Janestreet profile: do not break `fun _ -> function` (#2460) --- CHANGES.md | 1 + lib/Fmt_ast.ml | 4 +--- test/passing/tests/js_source.ml.ocp | 6 ++---- test/passing/tests/js_source.ml.ref | 14 ++++++-------- 4 files changed, 10 insertions(+), 15 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index a2cc1ff512..e6e4f1543d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -10,6 +10,7 @@ profile. This started with version 0.26.0. - Documentation comments are now formatted by default (#2390, @Julow) Use the option `parse-docstrings = false` to disable. +- \* Janestreet profile: do not break `fun _ -> function` (#2460, @tdelvecchio-jsc) ### Fixed diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 466d3cae99..494e4b26f0 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1386,9 +1386,7 @@ and fmt_fun ?force_closing_paren let body = let box = match xbody.ast.pexp_desc with - | Pexp_fun _ | Pexp_newtype _ -> Some false - | Pexp_function _ when not c.conf.fmt_opts.ocp_indent_compat.v -> - Some false + | Pexp_fun _ | Pexp_newtype _ | Pexp_function _ -> Some false | _ -> None in fmt_expression c ?box xbody diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 75df97a557..1c2c8bfaf1 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -10168,8 +10168,7 @@ let _ = Foooooooooooooooooooo.foooooooooooooooooooo foooooooooooooooooooo foooooooooooooooooooo - (fun x -> - function + (fun x -> function | Foooooooooooooooooooo -> foooooooooooooooooooo | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; @@ -10178,8 +10177,7 @@ let _ = Foooooooooooooooooooo.foooooooooooooooooooo foooooooooooooooooooo foooooooooooooooooooo - ~x:(fun x -> - function + ~x:(fun x -> function | Foooooooooooooooooooo -> foooooooooooooooooooo | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 8ffad9be24..d16b90e0b8 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -10168,20 +10168,18 @@ let _ = Foooooooooooooooooooo.foooooooooooooooooooo foooooooooooooooooooo foooooooooooooooooooo - (fun x -> - function - | Foooooooooooooooooooo -> foooooooooooooooooooo - | Foooooooooooooooooooo -> foooooooooooooooooooo) + (fun x -> function + | Foooooooooooooooooooo -> foooooooooooooooooooo + | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; let _ = Foooooooooooooooooooo.foooooooooooooooooooo foooooooooooooooooooo foooooooooooooooooooo - ~x:(fun x -> - function - | Foooooooooooooooooooo -> foooooooooooooooooooo - | Foooooooooooooooooooo -> foooooooooooooooooooo) + ~x:(fun x -> function + | Foooooooooooooooooooo -> foooooooooooooooooooo + | Foooooooooooooooooooo -> foooooooooooooooooooo) ;; let _ = From 245f525ddb25c8e3e27177b0269f0fc6ba606568 Mon Sep 17 00:00:00 2001 From: Thomas Del Vecchio <127883551+tdelvecchio-jsc@users.noreply.github.com> Date: Tue, 10 Oct 2023 04:37:46 -0400 Subject: [PATCH 15/19] Disable formatting of comments for the janestreet profile. (#2461) --- lib/Conf.ml | 2 +- test/passing/tests/js_source.ml.ocp | 12 +- test/passing/tests/js_source.ml.ref | 196 ++++++++++++++-------------- 3 files changed, 109 insertions(+), 101 deletions(-) diff --git a/lib/Conf.ml b/lib/Conf.ml index 88305fd889..be35cd1e53 100644 --- a/lib/Conf.ml +++ b/lib/Conf.ml @@ -231,7 +231,7 @@ let janestreet_profile from = ; parens_ite= elt true ; parens_tuple= elt `Multi_line_only ; parens_tuple_patterns= elt `Multi_line_only - ; parse_docstrings= elt true + ; parse_docstrings= elt false ; parse_toplevel_phrases= elt false ; sequence_blank_line= elt `Compact ; sequence_style= elt `Terminator diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index 1c2c8bfaf1..d97597045a 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -7888,7 +7888,7 @@ end = let _ = test 103 (Lazy.force M3.x) 3 -(** Pure type-checking tests: see recmod/*.ml *) +(** Pure type-checking tests: see recmod/*.ml *) type t = | A of { x : int @@ -9724,7 +9724,7 @@ module Intro_sort = struct 4-----o--------o--o--|-----o--4 | | | 5-----o--------------o-----o--5 - v} *) + v} *) foooooooooo fooooo fooo; foooooooooo fooooo fooo; foooooooooo fooooo fooo @@ -10231,7 +10231,9 @@ val fooooooooooooooooooooooooooooooo (* *) -(** xxx *) +(** + xxx +*) include S1 (** @inline *) @@ -10300,8 +10302,10 @@ type t = } (*{v + foo - v}*) + +v}*) let _ = match () with diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index d16b90e0b8..537b4eef59 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -896,7 +896,7 @@ let fint (type t) (x : t) (tag : t ty) = (* val fint : 'a -> 'a ty -> bool = *) (** OK: the return value is x > 0 of type bool; - This has used the equation t = bool, not visible in the return type **) +This has used the equation t = bool, not visible in the return type **) let f (type t) (x : t) (tag : t ty) = match tag with @@ -913,7 +913,7 @@ let g (type t) (x : t) (tag : t ty) = ;; (* Error: This expression has type bool but an expression was expected of type - t = int *) +t = int *) let id x = x @@ -1451,19 +1451,19 @@ let ty_list : type a e. (a, e) ty -> (a vlist, e) ty = (* type (_,_) ty_assoc = - | Anil : (unit,'e) ty_assoc - | Acons : string * ('a,'e) ty * ('b,'e) ty_assoc -> ('a -> 'b, 'e) ty_assoc + | Anil : (unit,'e) ty_assoc + | Acons : string * ('a,'e) ty * ('b,'e) ty_assoc -> ('a -> 'b, 'e) ty_assoc - and (_,_) ty_pvar = - | Pnil : ('a,'e) ty_pvar - | Pconst : 't * ('b,'e) ty_pvar -> ('t -> 'b, 'e) ty_pvar - | Parg : 't * ('a,'e) ty * ('b,'e) ty_pvar -> ('t * 'a -> 'b, 'e) ty_pvar +and (_,_) ty_pvar = + | Pnil : ('a,'e) ty_pvar + | Pconst : 't * ('b,'e) ty_pvar -> ('t -> 'b, 'e) ty_pvar + | Parg : 't * ('a,'e) ty * ('b,'e) ty_pvar -> ('t * 'a -> 'b, 'e) ty_pvar *) (* An attempt at encoding omega examples from the 2nd Central European Functional Programming School: - Generic Programming in Omega, by Tim Sheard and Nathan Linger - http://web.cecs.pdx.edu/~sheard/ + Generic Programming in Omega, by Tim Sheard and Nathan Linger + http://web.cecs.pdx.edu/~sheard/ *) (* Basic types *) @@ -1652,13 +1652,13 @@ type (_, _) diff = Diff : 'c nat * ('a, 'c, 'b) plus -> ('a, 'b) diff (* let rec diff : type a b. (a,b) le -> a nat -> b nat -> (a,b) diff = - fun le a b -> - match a, b, le with - | NZ, m, _ -> Diff (m, PlusZ m) - | NS x, NZ, _ -> assert false - | NS x, NS y, q -> - match diff (smaller q) x y with Diff (m, p) -> Diff (m, PlusS p) - ;; + fun le a b -> + match a, b, le with + | NZ, m, _ -> Diff (m, PlusZ m) + | NS x, NZ, _ -> assert false + | NS x, NS y, q -> + match diff (smaller q) x y with Diff (m, p) -> Diff (m, PlusS p) +;; *) let rec diff : type a b. (a, b) le -> a nat -> b nat -> (a, b) diff = @@ -2845,7 +2845,7 @@ type _ fin = | FS : 'a fin -> 'a succ fin (* We cannot define - val empty : zero fin -> 'a + val empty : zero fin -> 'a because we cannot write an empty pattern matching. This might be useful to have *) @@ -4629,20 +4629,20 @@ module M' : module type of Std'.M = Std2.M let f3 (x : M'.t) : Std2.M.t = x (* original report required Core_kernel: - module type S = sig - open Core_kernel.Std +module type S = sig +open Core_kernel.Std - module Hashtbl1 : module type of Hashtbl - module Hashtbl2 : sig - include (module type of Hashtbl) - end +module Hashtbl1 : module type of Hashtbl +module Hashtbl2 : sig + include (module type of Hashtbl) +end - module Coverage : Core_kernel.Std.Hashable +module Coverage : Core_kernel.Std.Hashable - type types = unit constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl1.t - type doesnt_type = unit - constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl2.t - end +type types = unit constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl1.t +type doesnt_type = unit + constraint 'a Coverage.Table.t = (Coverage.t, 'a) Hashtbl2.t +end *) module type INCLUDING = sig include module type of List @@ -4810,20 +4810,20 @@ module type PR6513 = sig end (* Requires -package tyxml - module type PR6513_orig = sig - module type S = - sig - type t - type u - end +module type PR6513_orig = sig +module type S = +sig + type t + type u +end - module Make: functor (Html5: Html5_sigs.T - with type 'a Xml.wrap = 'a and - type 'a wrap = 'a and - type 'a list_wrap = 'a list) - -> S with type t = Html5_types.div Html5.elt and - type u = < foo: Html5.uri > - end +module Make: functor (Html5: Html5_sigs.T + with type 'a Xml.wrap = 'a and + type 'a wrap = 'a and + type 'a list_wrap = 'a list) + -> S with type t = Html5_types.div Html5.elt and + type u = < foo: Html5.uri > +end *) module type S = sig include Set.S @@ -5030,9 +5030,9 @@ struct end (* This would allow: - module FixId = Fix (struct type 'a f = 'a end) - let bad : (int, string) eq = FixId.uniq Eq Eq - let _ = Printf.printf "Oh dear: %s" (cast bad 42) +module FixId = Fix (struct type 'a f = 'a end) + let bad : (int, string) eq = FixId.uniq Eq Eq + let _ = Printf.printf "Oh dear: %s" (cast bad 42) *) module M = struct module type S = sig @@ -5237,20 +5237,20 @@ module type S' = S with module M := String (* with module type *) (* module type S = sig module type T module F(X:T) : T end;; - module type T0 = sig type t end;; - module type S1 = S with module type T = T0;; - module type S2 = S with module type T := T0;; - module type S3 = S with module type T := sig type t = int end;; - module H = struct - include (Hashtbl : module type of Hashtbl with - type statistics := Hashtbl.statistics - and module type S := Hashtbl.S - and module Make := Hashtbl.Make - and module MakeSeeded := Hashtbl.MakeSeeded - and module type SeededS := Hashtbl.SeededS - and module type HashedType := Hashtbl.HashedType - and module type SeededHashedType := Hashtbl.SeededHashedType) - end;; +module type T0 = sig type t end;; +module type S1 = S with module type T = T0;; +module type S2 = S with module type T := T0;; +module type S3 = S with module type T := sig type t = int end;; +module H = struct + include (Hashtbl : module type of Hashtbl with + type statistics := Hashtbl.statistics + and module type S := Hashtbl.S + and module Make := Hashtbl.Make + and module MakeSeeded := Hashtbl.MakeSeeded + and module type SeededS := Hashtbl.SeededS + and module type HashedType := Hashtbl.HashedType + and module type SeededHashedType := Hashtbl.SeededHashedType) +end;; *) (* A subtle problem appearing with -principal *) @@ -5616,7 +5616,7 @@ struct end module G = F (M.Y) (*module N = G (M);; - module N = F (M.Y) (M);;*) +module N = F (M.Y) (M);;*) (* PR#6307 *) @@ -5675,16 +5675,16 @@ end (* fail *) (* (* if the above succeeded, one could break invariants *) - module rec M2 : S' = M2;; (* should succeed! (but this is bad) *) +module rec M2 : S' = M2;; (* should succeed! (but this is bad) *) - let M2.W eq = W Eq;; +let M2.W eq = W Eq;; - let s = List.fold_right SInt.add [1;2;3] SInt.empty;; - module SInt2 = Set.Make(Int2);; - let conv : type a b. (a,b) eq -> a -> b = fun Eq x -> x;; - let s' : SInt2.t = conv eq s;; - SInt2.elements s';; - SInt2.mem 2 s';; (* invariants are broken *) +let s = List.fold_right SInt.add [1;2;3] SInt.empty;; +module SInt2 = Set.Make(Int2);; +let conv : type a b. (a,b) eq -> a -> b = fun Eq x -> x;; +let s' : SInt2.t = conv eq s;; +SInt2.elements s';; +SInt2.mem 2 s';; (* invariants are broken *) *) (* Check behavior with submodules *) @@ -5868,14 +5868,14 @@ end = struct end (* The following introduces a (useless) dependency on A: - module C : sig module L : module type of List end = A +module C : sig module L : module type of List end = A *) include D' (* let () = - print_endline (string_of_int D'.M.y) + print_endline (string_of_int D'.M.y) *) open A @@ -5889,7 +5889,7 @@ end = struct end (* The following introduces a (useless) dependency on A: - module C : sig module L : module type of List end = A +module C : sig module L : module type of List end = A *) (* No dependency on D *) @@ -6076,13 +6076,13 @@ let f (x : entity entity_container) = () (* class world = - object - val entity_container : entity entity_container = new entity_container + object + val entity_container : entity entity_container = new entity_container - method add_entity (s : entity) = - entity_container#add_entity (s :> entity) + method add_entity (s : entity) = + entity_container#add_entity (s :> entity) - end + end *) (* Two v's in the same class *) class c v = @@ -6498,8 +6498,8 @@ end = struct end (* ocamlc -c pr3918a.mli pr3918b.mli - rm -f pr3918a.cmi - ocamlc -c pr3918c.ml + rm -f pr3918a.cmi + ocamlc -c pr3918c.ml *) open Pr3918b @@ -7380,9 +7380,9 @@ let _ = (* module rec Cyclic - : sig val x : int end - = struct let x = Cyclic.x + 1 end - ;; + : sig val x : int end + = struct let x = Cyclic.x + 1 end +;; *) (* Reordering of evaluation based on dependencies *) @@ -7477,15 +7477,15 @@ end (* module type ASig = sig type a val a:a val print:a -> unit end - module type BSig = sig type b val b:b val print:b -> unit end +module type BSig = sig type b val b:b val print:b -> unit end - module A = struct type a = int let a = 0 let print = print_int end - module B = struct type b = float let b = 0.0 let print = print_float end +module A = struct type a = int let a = 0 let print = print_int end +module B = struct type b = float let b = 0.0 let print = print_float end - module MakeA (Empty:sig end) : ASig = A - module MakeB (Empty:sig end) : BSig = B +module MakeA (Empty:sig end) : ASig = A +module MakeB (Empty:sig end) : BSig = B - module +module rec NewA : ASig = MakeA (struct end) and NewB : BSig with type b = NewA.a = MakeB (struct end);; *) @@ -7888,7 +7888,7 @@ end = let _ = test 103 (Lazy.force M3.x) 3 -(** Pure type-checking tests: see recmod/*.ml *) +(** Pure type-checking tests: see recmod/*.ml *) type t = | A of { x : int @@ -9659,7 +9659,7 @@ let g = f ~x (* this is a multiple-line-spanning - comment *) + comment *) ~y ;; @@ -9667,7 +9667,7 @@ let f = very_long_function_name ~x:very_long_variable_name (* this is a multiple-line-spanning - comment *) + comment *) ~y ;; @@ -9724,7 +9724,7 @@ module Intro_sort = struct 4-----o--------o--o--|-----o--4 | | | 5-----o--------------o-----o--5 - v} *) + v} *) foooooooooo fooooo fooo; foooooooooo fooooo fooo; foooooooooo fooooo fooo @@ -10229,9 +10229,11 @@ val fooooooooooooooooooooooooooooooo fooooooooooooooooooooooooooooooo (* - *) + *) -(** xxx *) +(** + xxx +*) include S1 (** @inline *) @@ -10300,8 +10302,10 @@ type t = } (*{v + foo - v}*) + +v}*) let _ = match () with @@ -10424,11 +10428,11 @@ let _ = xxxx] xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx [xxxxxxx] *) (* Hand-aligned comment - . + . . *) (* First line is indented more - . + . . *) module type M = sig From 12efce83832b13e5fc423dbb772fa411f1fce067 Mon Sep 17 00:00:00 2001 From: Thomas Del Vecchio <127883551+tdelvecchio-jsc@users.noreply.github.com> Date: Tue, 10 Oct 2023 11:48:34 -0400 Subject: [PATCH 16/19] Fix cinaps comment formatting to not change multiline string contents. (#2463) Rather than formatting comment code blocks into a string, and then converting that string back into an Fmt.t, we instead just generate the Fmt.t directly, which allows the styling to know about current indentation without needing to manually indent/unindent the formatted text. --- CHANGES.md | 1 + lib/Cmts.ml | 18 ++---------------- lib/Fmt_ast.ml | 15 +++++++++------ lib/Fmt_odoc.ml | 14 +++++++++----- lib/Fmt_odoc.mli | 6 +++++- lib/Normalize_extended_ast.ml | 19 ++++--------------- test/passing/tests/cinaps.ml.err | 1 + test/passing/tests/cinaps.ml.ref | 2 +- test/passing/tests/js_source.ml.ocp | 10 ++++------ test/passing/tests/js_source.ml.ref | 10 ++++------ 10 files changed, 40 insertions(+), 56 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index e6e4f1543d..9751fb5b59 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -19,6 +19,7 @@ profile. This started with version 0.26.0. - \* Consistent break after string constant argument (#2453, @Julow) - Fix invalid syntax generated with `ocp-indent-compat` (#2445, @Julow) - Fixed bug with attributes on sub-expressions of infix operators (#2459, @tdelvecchio-jsc) +- \* Fix cinaps comment formatting to not change multiline string contents (#2463, @tdelvecchio-jsc) ## 0.26.1 (2023-09-15) diff --git a/lib/Cmts.ml b/lib/Cmts.ml index 1c104e2609..fce91b6465 100644 --- a/lib/Cmts.ml +++ b/lib/Cmts.ml @@ -547,16 +547,7 @@ module Cinaps = struct (** Comments enclosed in [(*$], [$*)] are formatted as code. *) let fmt ~cls code = - let wrap k = hvbox 2 (fmt "(*$" $ k $ fmt cls) in - match String.split_lines code with - | [] | [""] -> wrap (str " ") - | [line] -> wrap (fmt "@ " $ str line $ fmt "@;<1 -2>") - | lines -> - let fmt_line = function - | "" -> fmt "\n" - | line -> fmt "@\n" $ str line - in - wrap (list lines "" fmt_line $ fmt "@;<1000 -2>") + hvbox 0 (fmt "(*$" $ hvbox (-1) (fmt "@;" $ code) $ fmt "@;" $ fmt cls) end module Ocp_indent_compat = struct @@ -608,12 +599,7 @@ let fmt_cmt (conf : Conf.t) cmt ~fmt_code pos = let len = String.length str - if dollar_suf then 2 else 1 in let offset = offset + 1 in let source = String.sub ~pos:1 ~len str in - let source = - String.split_lines source - |> Cmt.unindent_lines ~offset - |> String.concat ~sep:"\n" - in - match fmt_code conf ~offset source with + match fmt_code conf ~offset ~set_margin:false source with | Ok formatted -> `Code (formatted, cls) | Error (`Msg _) -> `Unwrapped (str, None) ) | txt when Char.equal txt.[0] '=' -> `Verbatim txt diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 494e4b26f0..d59dc2d6ed 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -4591,17 +4591,18 @@ let fmt_file (type a) ~ctx ~fmt_code ~debug (fragment : a Extended_ast.t) formatting doc. *) Fmt_odoc.fmt_ast c.conf ~fmt_code:c.fmt_code d -let fmt_parse_result conf ~debug ast_kind ast source comments ~fmt_code = +let fmt_parse_result conf ~debug ast_kind ast source comments + ~set_margin:set_margin_p ~fmt_code = let cmts = Cmts.init ast_kind ~debug source ast comments in let ctx = Top in let code = - set_margin conf.Conf.fmt_opts.margin.v + fmt_if_k set_margin_p (set_margin conf.Conf.fmt_opts.margin.v) $ fmt_file ~ctx ~debug ast_kind source cmts conf ast ~fmt_code in - Ok (Format_.asprintf "%a" Fmt.eval code) + Ok code let fmt_code ~debug = - let rec fmt_code (conf : Conf.t) ~offset s = + let rec fmt_code (conf : Conf.t) ~offset ~set_margin s = let {Conf.fmt_opts; _} = conf in let conf = (* Adjust margin according to [offset]. *) @@ -4615,9 +4616,11 @@ let fmt_code ~debug = ~input_name ~source:s with | Either.First {ast; comments; source; prefix= _} -> - fmt_parse_result conf ~debug Use_file ast source comments ~fmt_code + fmt_parse_result conf ~debug Use_file ast source comments ~set_margin + ~fmt_code | Second {ast; comments; source; prefix= _} -> - fmt_parse_result conf ~debug Repl_file ast source comments ~fmt_code + fmt_parse_result conf ~debug Repl_file ast source comments + ~set_margin ~fmt_code | exception Syntaxerr.Error (Expecting (_, x)) when warn -> Error (`Msg (Format.asprintf "expecting: %s" x)) | exception Syntaxerr.Error (Not_expecting (_, x)) when warn -> diff --git a/lib/Fmt_odoc.ml b/lib/Fmt_odoc.ml index 79930b5d34..fba43892eb 100644 --- a/lib/Fmt_odoc.ml +++ b/lib/Fmt_odoc.ml @@ -14,7 +14,11 @@ open Odoc_parser.Ast module Loc = Odoc_parser.Loc type fmt_code = - Conf.t -> offset:int -> string -> (string, [`Msg of string]) Result.t + Conf.t + -> offset:int + -> set_margin:bool + -> string + -> (Fmt.t, [`Msg of string]) Result.t type c = {fmt_code: fmt_code; conf: Conf.t} @@ -119,8 +123,8 @@ let fmt_code_block c s1 s2 = match s1 with | Some ({value= "ocaml"; _}, _) | None -> ( (* [offset] doesn't take into account code blocks nested into lists. *) - match c.fmt_code c.conf ~offset:2 original with - | Ok formatted -> fmt_code formatted + match c.fmt_code c.conf ~offset:2 ~set_margin:true original with + | Ok formatted -> formatted |> Format_.asprintf "%a" Fmt.eval |> fmt_code | Error (`Msg message) -> ( match message with | "" -> () @@ -356,8 +360,8 @@ let fmt_parsed (conf : Conf.t) ~fmt_code ~input ~offset parsed = let begin_offset = beginning_offset conf input in (* The offset is used to adjust the margin when formatting code blocks. *) let offset = offset + begin_offset in - let fmt_code conf ~offset:offset' input = - fmt_code conf ~offset:(offset + offset') input + let fmt_code conf ~offset:offset' ~set_margin input = + fmt_code conf ~offset:(offset + offset') ~set_margin input in let fmt_parsed parsed = str (String.make begin_offset ' ') diff --git a/lib/Fmt_odoc.mli b/lib/Fmt_odoc.mli index a5001e0cfc..e034afccc0 100644 --- a/lib/Fmt_odoc.mli +++ b/lib/Fmt_odoc.mli @@ -12,7 +12,11 @@ (** [offset] is the column at which the content of the comment begins. It is used to adjust the margin. *) type fmt_code = - Conf.t -> offset:int -> string -> (string, [`Msg of string]) Result.t + Conf.t + -> offset:int + -> set_margin:bool + -> string + -> (Fmt.t, [`Msg of string]) Result.t val fmt_ast : Conf.t -> fmt_code:fmt_code -> Odoc_parser.Ast.t -> Fmt.t diff --git a/lib/Normalize_extended_ast.ml b/lib/Normalize_extended_ast.ml index 99f74d03a8..c7634794de 100644 --- a/lib/Normalize_extended_ast.ml +++ b/lib/Normalize_extended_ast.ml @@ -11,10 +11,6 @@ open Extended_ast -let start_column loc = - let pos = loc.Location.loc_start in - pos.pos_cnum - pos.pos_bol - let dedup_cmts fragment ast comments = let of_ast ast = let docs = ref (Set.empty (module Cmt)) in @@ -53,12 +49,7 @@ let normalize_parse_result ast_kind ast comments = (normalize_comments (dedup_cmts ast_kind ast)) comments -let normalize_code conf (m : Ast_mapper.mapper) ~offset txt = - let txt = - String.split_lines txt - |> Cmt.unindent_lines ~offset - |> String.concat ~sep:"\n" - in +let normalize_code conf (m : Ast_mapper.mapper) txt = let input_name = "" in match Parse_with_comments.parse_toplevel conf ~input_name ~source:txt with | First {ast; comments; _} -> @@ -97,7 +88,7 @@ let make_mapper conf ~ignore_doc_comments = when Ast.Attr.is_doc attr -> let normalize_code = (* Indentation is already stripped by odoc-parser. *) - normalize_code conf m ~offset:0 + normalize_code conf m in let doc' = docstring conf ~normalize_code doc in Ast_mapper.default_mapper.attribute m @@ -182,8 +173,7 @@ let diff ~f ~cmt_kind x y = let diff_docstrings c x y = let mapper = make_mapper c ~ignore_doc_comments:false in let docstring cmt = - let offset = start_column (Cmt.loc cmt) + 3 in - let normalize_code = normalize_code c mapper ~offset in + let normalize_code = normalize_code c mapper in docstring c ~normalize_code (Cmt.txt cmt) in let norm z = @@ -212,8 +202,7 @@ let diff_cmts (conf : Conf.t) x y = let len = String.length str - chars_removed in let source = String.sub ~pos:1 ~len str in let loc = Cmt.loc z in - let offset = start_column loc + 3 in - Cmt.create_comment (normalize_code ~offset source) loc + Cmt.create_comment (normalize_code source) loc else norm_non_code z in Set.of_list (module Cmt.Comparator_no_loc) (List.map ~f z) diff --git a/test/passing/tests/cinaps.ml.err b/test/passing/tests/cinaps.ml.err index e69de29bb2..6c128b0f94 100644 --- a/test/passing/tests/cinaps.ml.err +++ b/test/passing/tests/cinaps.ml.err @@ -0,0 +1 @@ +Warning: tests/cinaps.ml:24 exceeds the margin diff --git a/test/passing/tests/cinaps.ml.ref b/test/passing/tests/cinaps.ml.ref index 141ed76d1b..71fc3755f2 100644 --- a/test/passing/tests/cinaps.ml.ref +++ b/test/passing/tests/cinaps.ml.ref @@ -22,7 +22,7 @@ let y = 2 #use "import.cinaps" ;; List.iter all_fields ~f:(fun (name, type_) -> - printf "\nexternal get_%s\n: unit -> %s = \"get_%s\"" name type_ name ) + printf "\nexternal get_%s\n : unit -> %s = \"get_%s\"" name type_ name ) *) external get_name : unit -> string = "get_name" diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp index d97597045a..1c092ebdc0 100644 --- a/test/passing/tests/js_source.ml.ocp +++ b/test/passing/tests/js_source.ml.ocp @@ -10325,15 +10325,13 @@ let _ = (*$ [%string {| xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx - zzzzzzzzzzzzzzzzzzzzzzzzzzzz - |}] +zzzzzzzzzzzzzzzzzzzzzzzzzzzz + |}] *) (*$*) -(*$ - {| - f|} -*) +(*$ {| + f|} *) let () = match () with diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref index 537b4eef59..bc74fe3a0f 100644 --- a/test/passing/tests/js_source.ml.ref +++ b/test/passing/tests/js_source.ml.ref @@ -10325,15 +10325,13 @@ let _ = (*$ [%string {| xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx - zzzzzzzzzzzzzzzzzzzzzzzzzzzz - |}] +zzzzzzzzzzzzzzzzzzzzzzzzzzzz + |}] *) (*$*) -(*$ - {| - f|} -*) +(*$ {| + f|} *) let () = match () with From b1788844c29b546142d48148bb4bc222d51aa886 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Wed, 11 Oct 2023 09:42:25 +0100 Subject: [PATCH 17/19] Reduce the indentation of (polytype) type constraints (#2437) --- CHANGES.md | 1 + lib/Fmt_ast.ml | 40 ++++++++++--------- lib/box_debug.ml | 3 +- test/passing/tests/break_colon.ml | 4 +- ...ocp_indent_compat-break_colon_after.ml.ref | 4 +- test/passing/tests/polytypes-default.ml.ref | 40 +++++++++++++------ .../passing/tests/polytypes-janestreet.ml.err | 1 + .../passing/tests/polytypes-janestreet.ml.ref | 17 ++++++++ test/passing/tests/polytypes.ml | 40 +++++++++++++------ test/passing/tests/source.ml.err | 2 +- test/passing/tests/source.ml.ref | 40 +++++++------------ 11 files changed, 116 insertions(+), 76 deletions(-) create mode 100644 test/passing/tests/polytypes-janestreet.ml.err diff --git a/CHANGES.md b/CHANGES.md index 9751fb5b59..15e9d49c77 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -11,6 +11,7 @@ profile. This started with version 0.26.0. - Documentation comments are now formatted by default (#2390, @Julow) Use the option `parse-docstrings = false` to disable. - \* Janestreet profile: do not break `fun _ -> function` (#2460, @tdelvecchio-jsc) +- \* Reduce the indentation of (polytype) type constraints (#2437, @gpetiot) ### Fixed diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index d59dc2d6ed..330dd29cdd 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -4353,29 +4353,32 @@ and fmt_value_binding c ~rec_flag ?ext ?in_ ?epi in let doc1, atrs = doc_atrs lb_attrs in let doc2, atrs = doc_atrs atrs in - let fmt_cstr = + let fmt_newtypes, fmt_cstr = let fmt_sep x = match c.conf.fmt_opts.break_colon.v with | `Before -> fmt "@ " $ str x $ char ' ' | `After -> char ' ' $ str x $ fmt "@ " in match lb_typ with - | `Polynewtype (pvars, xtyp) -> - fmt_sep ":" - $ hvbox 0 - ( str "type " - $ list pvars " " (fmt_str_loc c) - $ fmt ".@ " $ fmt_core_type c xtyp ) + | `Polynewtype (pvars, xtyp) -> ( + match c.conf.fmt_opts.break_colon.v with + | `Before -> + ( noop + , fmt_sep ":" + $ hvbox 0 + ( str "type " + $ list pvars " " (fmt_str_loc c) + $ fmt ".@ " $ fmt_core_type c xtyp ) ) + | `After -> + ( fmt_sep ":" + $ hvbox 0 (str "type " $ list pvars " " (fmt_str_loc c) $ str ".") + , fmt "@ " $ fmt_core_type c xtyp ) ) | `Coerce (xtyp1, xtyp2) -> - opt xtyp1 (fun xtyp1 -> fmt_sep ":" $ fmt_core_type c xtyp1) - $ fmt_sep ":>" $ fmt_core_type c xtyp2 - | `Other xtyp -> fmt_type_cstr c xtyp - | `None -> noop - in - let cstr_indent = - match lb_typ with - | `Other {ast= {ptyp_desc= Ptyp_poly _; _}; _} -> 6 - | _ -> 4 + ( noop + , opt xtyp1 (fun xtyp1 -> fmt_sep ":" $ fmt_core_type c xtyp1) + $ fmt_sep ":>" $ fmt_core_type c xtyp2 ) + | `Other xtyp -> (noop, fmt_type_cstr c xtyp) + | `None -> (noop, noop) in let indent = match lb_exp.ast.pexp_desc with @@ -4416,7 +4419,7 @@ and fmt_value_binding c ~rec_flag ?ext ?in_ ?epi ( hvbox_if toplevel 0 ( hvbox_if toplevel indent ( hovbox 2 - ( hovbox cstr_indent + ( hovbox 4 ( box_fun_decl_args c 4 ( hovbox 4 ( fmt_str_loc c lb_op @@ -4429,7 +4432,8 @@ and fmt_value_binding c ~rec_flag ?ext ?in_ ?epi (not (List.is_empty lb_args)) ( fmt "@ " $ wrap_fun_decl_args c - (fmt_fun_args c lb_args) ) ) + (fmt_fun_args c lb_args) ) + $ fmt_newtypes ) $ fmt_cstr ) $ fmt_if_k (not lb_pun) (fmt_or_k c.conf.fmt_opts.ocp_indent_compat.v diff --git a/lib/box_debug.ml b/lib/box_debug.ml index f4db9027ff..f76d968183 100644 --- a/lib/box_debug.ml +++ b/lib/box_debug.ml @@ -120,8 +120,7 @@ let _pp_format_lit fs = | Escaped_percent -> fprintf fs "@@%%" | Scan_indic c -> pp_keyword fs ("@" ^ String.make 1 c) -let rec _format_string : - type a b c d e f. +let rec _format_string : type a b c d e f. _ -> (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> unit = let open CamlinternalFormatBasics in fun fs -> function diff --git a/test/passing/tests/break_colon.ml b/test/passing/tests/break_colon.ml index 573c51e033..61c9741e50 100644 --- a/test/passing/tests/break_colon.ml +++ b/test/passing/tests/break_colon.ml @@ -76,8 +76,8 @@ let ssmap : -> unit = () -let long_function_name : - type a. a long_long_type -> a -> a -> a -> wrap_wrap_wrap -> unit = +let long_function_name : type a. + a long_long_type -> a -> a -> a -> wrap_wrap_wrap -> unit = fun () -> () let array_fold_transf (f : numbering -> 'a -> numbering * 'b) n (a : 'a array) diff --git a/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref b/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref index 633d0168dc..5afc5d045f 100644 --- a/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref +++ b/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref @@ -79,8 +79,8 @@ let ssmap : = () -let long_function_name : - type a. a long_long_type -> a -> a -> a -> wrap_wrap_wrap -> unit +let long_function_name : type a. + a long_long_type -> a -> a -> a -> wrap_wrap_wrap -> unit = fun () -> () diff --git a/test/passing/tests/polytypes-default.ml.ref b/test/passing/tests/polytypes-default.ml.ref index c14913a520..9358065892 100644 --- a/test/passing/tests/polytypes-default.ml.ref +++ b/test/passing/tests/polytypes-default.ml.ref @@ -1,25 +1,25 @@ let t1 : 'a 'b. 'a t -> b t = () let t2 : - 'a 'b. - 'a t________________________________ -> - 'b t_______________________________________ = + 'a 'b. + 'a t________________________________ -> + 'b t_______________________________________ = () let t3 : - 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that - 'must 'wrap. - 'a t_________________________________________________ -> - 'b t______________________________________________________________ -> - 'c t______________________________________________________________ = + 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must + 'wrap. + 'a t_________________________________________________ -> + 'b t______________________________________________________________ -> + 'c t______________________________________________________________ = () let t4 : - 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that - 'must 'wrap. - 'a t_________________________________________________ - * 'b t______________________________________________________________ - * 'c t______________________________________________________________ = + 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must + 'wrap. + 'a t_________________________________________________ + * 'b t______________________________________________________________ + * 'c t______________________________________________________________ = () let foo : type a. a = @@ -33,3 +33,17 @@ class c = let _ = let id : 'a. 'a -> 'a = fun x -> x in () + +let equal_list : + 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = + fun es1 es2 -> + try List.for_all2 equal es1 es2 with Invalid_argument _ -> false + +let rec equal_list : + 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = + fun es1 es2 -> + try List.for_all2 equal es1 es2 with Invalid_argument _ -> false + +and equal : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr marked -> bool = + fun (type a) (e1 : (a, 't) gexpr marked) (e2 : (a, 't) gexpr marked) -> + match (Marked.unmark e1, Marked.unmark e2) with x -> x diff --git a/test/passing/tests/polytypes-janestreet.ml.err b/test/passing/tests/polytypes-janestreet.ml.err new file mode 100644 index 0000000000..b477480650 --- /dev/null +++ b/test/passing/tests/polytypes-janestreet.ml.err @@ -0,0 +1 @@ +Warning: tests/polytypes.ml:47 exceeds the margin diff --git a/test/passing/tests/polytypes-janestreet.ml.ref b/test/passing/tests/polytypes-janestreet.ml.ref index 963ec381b0..a35e53e6b5 100644 --- a/test/passing/tests/polytypes-janestreet.ml.ref +++ b/test/passing/tests/polytypes-janestreet.ml.ref @@ -38,3 +38,20 @@ let _ = let id : 'a. 'a -> 'a = fun x -> x in () ;; + +let equal_list : 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = + fun es1 es2 -> + try List.for_all2 equal es1 es2 with + | Invalid_argument _ -> false +;; + +let rec equal_list : 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = + fun es1 es2 -> + try List.for_all2 equal es1 es2 with + | Invalid_argument _ -> false + +and equal : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr marked -> bool = + fun (type a) (e1 : (a, 't) gexpr marked) (e2 : (a, 't) gexpr marked) -> + match Marked.unmark e1, Marked.unmark e2 with + | x -> x +;; diff --git a/test/passing/tests/polytypes.ml b/test/passing/tests/polytypes.ml index 83cdbfef5d..9a9ae969df 100644 --- a/test/passing/tests/polytypes.ml +++ b/test/passing/tests/polytypes.ml @@ -1,25 +1,25 @@ let t1 : 'a 'b. 'a t -> b t = () let t2 : - 'a 'b. - 'a t________________________________ - -> 'b t_______________________________________ = + 'a 'b. + 'a t________________________________ + -> 'b t_______________________________________ = () let t3 : - 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that - 'must 'wrap. - 'a t_________________________________________________ - -> 'b t______________________________________________________________ - -> 'c t______________________________________________________________ = + 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that + 'must 'wrap. + 'a t_________________________________________________ + -> 'b t______________________________________________________________ + -> 'c t______________________________________________________________ = () let t4 : - 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that - 'must 'wrap. - 'a t_________________________________________________ - * 'b t______________________________________________________________ - * 'c t______________________________________________________________ = + 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that + 'must 'wrap. + 'a t_________________________________________________ + * 'b t______________________________________________________________ + * 'c t______________________________________________________________ = () let foo : type a. a = @@ -33,3 +33,17 @@ class c = let _ = let id : 'a. 'a -> 'a = fun x -> x in () + +let equal_list : + 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = + fun es1 es2 -> + try List.for_all2 equal es1 es2 with Invalid_argument _ -> false + +let rec equal_list : + 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool = + fun es1 es2 -> + try List.for_all2 equal es1 es2 with Invalid_argument _ -> false + +and equal : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr marked -> bool = + fun (type a) (e1 : (a, 't) gexpr marked) (e2 : (a, 't) gexpr marked) -> + match (Marked.unmark e1, Marked.unmark e2) with x -> x diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index 50f7e55a5d..16b867f5da 100644 --- a/test/passing/tests/source.ml.err +++ b/test/passing/tests/source.ml.err @@ -1,2 +1,2 @@ Warning: tests/source.ml:702 exceeds the margin -Warning: tests/source.ml:2318 exceeds the margin +Warning: tests/source.ml:2311 exceeds the margin diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 80b701989f..0ec00cfffc 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -1206,8 +1206,8 @@ type _ ty_env = (* Comparing selectors *) type (_, _) eq = Eq : ('a, 'a) eq -let rec eq_sel : - type a b c. (a, b) ty_sel -> (a, c) ty_sel -> (b, c) eq option = +let rec eq_sel : type a b c. + (a, b) ty_sel -> (a, c) ty_sel -> (b, c) eq option = fun s1 s2 -> match (s1, s2) with | Thd, Thd -> Some Eq @@ -1216,8 +1216,7 @@ let rec eq_sel : | _ -> None (* Auxiliary function to get the type of a case from its selector *) -let rec get_case : - type a b e. +let rec get_case : type a b e. (b, a) ty_sel -> (string * (e, b) ty_case) list -> string * (a, e) ty option = @@ -1312,8 +1311,7 @@ let ty_abc = | `B s -> ("B", Some (Tdyn (String, s))) | `C -> ("C", None) (* Define inj in advance to be able to write the type annotation easily *) - and inj : - type c. + and inj : type c. (int -> string -> noarg -> unit, c) ty_sel * c -> [`A of int | `B of string | `C] = function | Thd, v -> `A v @@ -1560,9 +1558,8 @@ type (_, _) tree = let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3)) -let rec find : - type sh. ('a -> 'a -> bool) -> 'a -> (sh, 'a) tree -> (sh, 'a) path list - = +let rec find : type sh. + ('a -> 'a -> bool) -> 'a -> (sh, 'a) tree -> (sh, 'a) path list = fun eq n t -> match t with | Ttip -> [] @@ -1623,8 +1620,8 @@ let rec sameNat : type a b. a nat -> b nat -> (a, b) equal option = (* Extra: associativity of addition *) -let rec plus_func : - type a b m n. (a, b, m) plus -> (a, b, n) plus -> (m, n) equal = +let rec plus_func : type a b m n. + (a, b, m) plus -> (a, b, n) plus -> (m, n) equal = fun p1 p2 -> match (p1, p2) with | PlusZ _, PlusZ _ -> Eq @@ -1632,8 +1629,7 @@ let rec plus_func : let Eq = plus_func p1' p2' in Eq -let rec plus_assoc : - type a b c ab bc m n. +let rec plus_assoc : type a b c ab bc m n. (a, b, ab) plus -> (ab, c, m) plus -> (b, c, bc) plus @@ -1724,8 +1720,7 @@ let rec elem : type h. int -> h avl -> bool = | Leaf -> false | Node (_, l, y, r) -> x = y || if x < y then elem x l else elem x r -let rec rotr : - type n. +let rec rotr : type n. n succ succ avl -> int -> n avl @@ -1741,8 +1736,7 @@ let rec rotr : | Node (Less, a, x, Node (More, b, z, c)) -> Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR))) -let rec rotl : - type n. +let rec rotl : type n. n avl -> int -> n succ succ avl @@ -2223,8 +2217,7 @@ type closed = rnil type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum -let rec rule : - type a b. +let rec rule : type a b. (pval, closed, (a, b) tarr) lam -> (pval, closed, a) lam -> b rlam = fun v1 v2 -> match (v1, v2) with @@ -4099,16 +4092,14 @@ end = struct let _ = fun (_ : ('a, 'perms) t) -> () let t_of_sexp : - 'a 'perms. (sexp -> 'a) -> (sexp -> 'perms) -> sexp -> ('a, 'perms) t - = + 'a 'perms. (sexp -> 'a) -> (sexp -> 'perms) -> sexp -> ('a, 'perms) t = let _tp_loc = "core_array.ml.Permissioned.t" in fun _of_a _of_perms t -> (array_of_sexp _of_a) t let _ = t_of_sexp let sexp_of_t : - 'a 'perms. ('a -> sexp) -> ('perms -> sexp) -> ('a, 'perms) t -> sexp - = + 'a 'perms. ('a -> sexp) -> ('perms -> sexp) -> ('a, 'perms) t -> sexp = fun _of_a _of_perms v -> (sexp_of_array _of_a) v let _ = sexp_of_t @@ -8372,8 +8363,7 @@ type (_, _, _, _) u = U : (int, int, int, int) u type v = E | F | G -let f : - type a b c d e f g. +let f : type a b c d e f g. a t * b t * c t From 47bfef0a0873e91bb5632617bfd0546237c61eff Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Thu, 19 Oct 2023 14:15:38 +0100 Subject: [PATCH 18/19] Define type 'type_constraint' (#2464) --- lib/Ast.ml | 11 ++++++----- lib/Extended_ast.ml | 25 +++++++++++++++++++------ lib/Fmt_ast.ml | 20 +++++++++++++------- vendor/parser-extended/ast_mapper.ml | 7 ++++++- vendor/parser-extended/parser.mly | 28 ++++++++++++++-------------- vendor/parser-extended/parsetree.mli | 6 +++++- vendor/parser-extended/printast.ml | 15 ++++++++++++--- 7 files changed, 75 insertions(+), 37 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index c47beb25f2..a69165a7f2 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -981,8 +981,10 @@ end = struct | Pexp_object _ -> assert false | Pexp_record (en1, _) -> assert ( - List.exists en1 ~f:(fun (_, (t1, t2), _) -> - Option.exists t1 ~f || Option.exists t2 ~f ) ) + List.exists en1 ~f:(fun (_, c, _) -> + Option.exists c ~f:(function + | Pconstraint t -> f t + | Pcoerce (t1, t2) -> Option.exists t1 ~f || f t2 ) ) ) | Pexp_let (lbs, _) -> assert (check_let_bindings lbs) | _ -> assert false ) | Lb _ -> assert false @@ -1501,9 +1503,8 @@ end = struct List.for_all e1N ~f:Exp.is_trivial && fit_margin c (width xexp) | Pexp_record (e1N, e0) -> Option.for_all e0 ~f:Exp.is_trivial - && List.for_all e1N ~f:(fun (_, (ct1, ct2), eo) -> - Option.is_none ct1 && Option.is_none ct2 - && Option.for_all eo ~f:Exp.is_trivial ) + && List.for_all e1N ~f:(fun (_, c, eo) -> + Option.is_none c && Option.for_all eo ~f:Exp.is_trivial ) && fit_margin c (width xexp) | Pexp_indexop_access {pia_lhs; pia_kind; pia_rhs= None; _} -> Exp.is_trivial pia_lhs diff --git a/lib/Extended_ast.ml b/lib/Extended_ast.ml index 34445fd11c..8e37fbc259 100644 --- a/lib/Extended_ast.ml +++ b/lib/Extended_ast.ml @@ -69,8 +69,21 @@ module Parse = struct when Std_longident.field_alias ~field:f.txt v_txt -> (f, t, None) (* [{ x = (x : t) }] -> [{ x : t }] *) + | ( None + , Some + { pexp_desc= + Pexp_constraint + ( { pexp_desc= Pexp_ident {txt= v_txt; _} + ; pexp_attributes= [] + ; _ } + , t1 ) + ; pexp_attributes= [] + ; _ } ) + when enable_short_field_annot + && Std_longident.field_alias ~field:f.txt v_txt -> + (f, Some (Pconstraint t1), None) (* [{ x :> t = (x : t) }] -> [{ x : t :> t }] *) - | ( (None, t2) + | ( Some (Pcoerce (None, t2)) , Some { pexp_desc= Pexp_constraint @@ -82,10 +95,10 @@ module Parse = struct ; _ } ) when enable_short_field_annot && Std_longident.field_alias ~field:f.txt v_txt -> - (f, (Some t1, t2), None) + (f, Some (Pcoerce (Some t1, t2)), None) (* [{ x = (x :> t) }] -> [{ x :> t }] *) (* [{ x = (x : t :> t) }] -> [{ x : t :> t }] *) - | ( (None, None) + | ( None , Some { pexp_desc= Pexp_coerce @@ -98,9 +111,9 @@ module Parse = struct ; _ } ) when enable_short_field_annot && Std_longident.field_alias ~field:f.txt v_txt -> - (f, (t1, Some t2), None) + (f, Some (Pcoerce (t1, t2)), None) (* [{ x : t = (x :> t) }] -> [{ x : t :> t }] *) - | ( (Some t1, None) + | ( Some (Pconstraint t1) , Some { pexp_desc= Pexp_coerce @@ -113,7 +126,7 @@ module Parse = struct ; _ } ) when enable_short_field_annot && Std_longident.field_alias ~field:f.txt v_txt -> - (f, (Some t1, Some t2), None) + (f, Some (Pcoerce (Some t1, t2)), None) | _ -> (f, t, Option.map ~f:(m.expr m) v) in let pat_record_field m (f, t, v) = diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 330dd29cdd..70910c9de7 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -2469,7 +2469,13 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (Params.parens_if outer_parens c.conf (compose_module ~pro ~epi blk ~f:fmt_mod $ fmt_atrs) ) | Pexp_record (flds, default) -> - let fmt_field (lid, (typ1, typ2), exp) = + let fmt_field (lid, tc, exp) = + let typ1, typ2 = + match tc with + | Some (Pconstraint t1) -> (Some t1, None) + | Some (Pcoerce (t1, t2)) -> (t1, Some t2) + | None -> (None, None) + in let typ1 = Option.map typ1 ~f:(sub_typ ~ctx) in let typ2 = Option.map typ2 ~f:(sub_typ ~ctx) in let rhs = @@ -2478,12 +2484,12 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens hvbox 0 @@ fmt_record_field c ?typ1 ?typ2 ?rhs lid in let p1, p2 = Params.get_record_expr c.conf in - let last_loc (lid, (t1, t2), e) = - match (t1, t2, e) with - | _, _, Some e -> e.pexp_loc - | _, Some t2, _ -> t2.ptyp_loc - | Some t1, _, _ -> t1.ptyp_loc - | _ -> lid.loc + let last_loc (lid, tc, e) = + match (tc, e) with + | _, Some e -> e.pexp_loc + | Some (Pcoerce (_, t2)), None -> t2.ptyp_loc + | Some (Pconstraint t1), None -> t1.ptyp_loc + | None, None -> lid.loc in let fmt_fields = fmt_elements_collection c p1 last_loc pexp_loc fmt_field flds diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index b1da740668..cbf8841c2f 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -467,6 +467,11 @@ end module E = struct (* Value expressions for the core language *) + let map_constraint sub c = + match c with + | Pconstraint ty -> Pconstraint (sub.typ sub ty) + | Pcoerce (ty1, ty2) -> Pcoerce (map_opt (sub.typ sub) ty1, sub.typ sub ty2) + let map_if_branch sub {if_cond; if_body; if_attrs} = let if_cond = sub.expr sub if_cond in let if_body = sub.expr sub if_body in @@ -507,7 +512,7 @@ module E = struct List.map (map_tuple3 (map_loc sub) - (map_tuple (map_opt (sub.typ sub)) (map_opt (sub.typ sub))) + (map_opt (map_constraint sub)) (map_opt (sub.expr sub))) l in diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index 26673cdfae..dc65b85aa2 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -226,11 +226,13 @@ let rec mktailpat nilloc = let open Location in function let mkstrexp e attrs = { pstr_desc = Pstr_eval (e, attrs); pstr_loc = e.pexp_loc } -let mkexp_constraint ~loc e (t1, t2) = - match t1, t2 with - | Some t, None -> mkexp ~loc (Pexp_constraint(e, t)) - | _, Some t -> mkexp ~loc (Pexp_coerce(e, t1, t)) - | None, None -> assert false +let mkexp_desc_constraint e t = + match t with + | Pconstraint t -> Pexp_constraint(e, t) + | Pcoerce(t1, t2) -> Pexp_coerce(e, t1, t2) + +let mkexp_constraint ~loc e t = + mkexp ~loc (mkexp_desc_constraint e t) (* let mkexp_opt_constraint ~loc e = function @@ -2484,10 +2486,9 @@ let_binding_body_no_punning: { let v = $1 in (* PR#7344 *) let t = match $2 with - Some t, None -> - Pvc_constraint { locally_abstract_univars = []; typ=t } - | ground, Some coercion -> Pvc_coercion { ground; coercion} - | _ -> assert false + | Pconstraint typ -> + Pvc_constraint { locally_abstract_univars = []; typ } + | Pcoerce (ground, coercion) -> Pvc_coercion { ground; coercion } in (v, $4, Some t) } @@ -2623,8 +2624,7 @@ record_expr_content: | label = mkrhs(label_longident) c = type_constraint? eo = preceded(EQUAL, expr)? - { let c = Option.value ~default:(None, None) c in - label, c, eo } + { label, c, eo } ; %inline object_expr_content: xs = separated_or_terminated_nonempty_list(SEMI, object_expr_field) @@ -2648,9 +2648,9 @@ record_expr_content: { es } ; type_constraint: - COLON core_type { (Some $2, None) } - | COLON core_type COLONGREATER core_type { (Some $2, Some $4) } - | COLONGREATER core_type { (None, Some $2) } + | COLON core_type { Pconstraint $2 } + | COLON core_type COLONGREATER core_type { Pcoerce (Some $2, $4) } + | COLONGREATER core_type { Pcoerce (None, $2) } | COLON error { syntax_error() } | COLONGREATER error { syntax_error() } ; diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index dea619a38b..8e3ebfd8a2 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -377,7 +377,7 @@ and expression_desc = *) | Pexp_record of ( Longident.t loc - * (core_type option * core_type option) + * type_constraint option * expression option ) list * expression option @@ -501,6 +501,10 @@ and binding_op = pbop_loc : Location.t; } +and type_constraint = + | Pconstraint of core_type + | Pcoerce of core_type option * core_type + (** {2 Value descriptions} *) and value_description = diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index 51f196eecb..28ea03b656 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -514,6 +514,16 @@ and if_branch i ppf { if_cond; if_body } = expression i ppf if_cond; expression i ppf if_body +and type_constraint i ppf constraint_ = + match constraint_ with + | Pconstraint ty -> + line i ppf "Pconstraint\n"; + core_type (i+1) ppf ty + | Pcoerce (ty1, ty2) -> + line i ppf "Pcoerce\n"; + option (i+1) core_type ppf ty1; + core_type (i+1) ppf ty2 + and value_description i ppf x = line i ppf "value_description %a %a\n" fmt_string_loc x.pval_name fmt_location x.pval_loc; @@ -1119,10 +1129,9 @@ and string_x_expression i ppf (s, e) = line i ppf " %a\n" fmt_string_loc s; expression (i+1) ppf e; -and longident_x_expression i ppf (li, (t1, t2), e) = +and longident_x_expression i ppf (li, c, e) = line i ppf "%a\n" fmt_longident_loc li; - option (i+1) core_type ppf t1; - option (i+1) core_type ppf t2; + option (i+1) type_constraint ppf c; option (i+1) expression ppf e; and label_x_expression i ppf (l,e) = From 181da779ad5cb6a19014b3c26cf13a0d244e9e4f Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Mon, 23 Oct 2023 03:06:06 +0100 Subject: [PATCH 19/19] Define type function_param and replace Sugar.arg_kind (#2466) * Define type 'function_param' * Add Fp in the Ast context * Replace Sugar.arg_kind with function_param --- lib/Ast.ml | 25 ++++++++- lib/Ast.mli | 1 + lib/Fmt_ast.ml | 77 +++++++++++++++------------- lib/Sugar.ml | 53 +++++++++++++------ lib/Sugar.mli | 10 ++-- vendor/parser-extended/ast_mapper.ml | 14 +++++ vendor/parser-extended/parsetree.mli | 32 ++++++++++++ vendor/parser-extended/printast.ml | 14 +++++ 8 files changed, 166 insertions(+), 60 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index a69165a7f2..43f1073c4e 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -638,6 +638,7 @@ module T = struct | Cty of class_type | Pat of pattern | Exp of expression + | Fp of function_param | Lb of value_binding | Mb of module_binding | Md of module_declaration @@ -658,6 +659,7 @@ module T = struct | Td t -> Format.fprintf fs "Td:@\n%a" Printast.type_declaration t | Pat p -> Format.fprintf fs "Pat:@\n%a" Printast.pattern p | Exp e -> Format.fprintf fs "Exp:@\n%a" Printast.expression e + | Fp p -> Format.fprintf fs "Fp:@\n%a" Printast.function_param p | Lb b -> Format.fprintf fs "Lb:@\n%a" Printast.value_binding b | Mb m -> Format.fprintf fs "Mb:@\n%a" Printast.module_binding m | Md m -> Format.fprintf fs "Md:@\n%a" Printast.module_declaration m @@ -690,6 +692,7 @@ let attributes = function | Cty x -> x.pcty_attributes | Pat x -> x.ppat_attributes | Exp x -> x.pexp_attributes + | Fp _ -> [] | Lb x -> x.pvb_attributes | Mb x -> attrs_of_ext_attrs x.pmb_ext_attrs | Md x -> attrs_of_ext_attrs x.pmd_ext_attrs @@ -711,6 +714,7 @@ let location = function | Cty x -> x.pcty_loc | Pat x -> x.ppat_loc | Exp x -> x.pexp_loc + | Fp x -> x.pparam_loc | Lb x -> x.pvb_loc | Mb x -> x.pmb_loc | Md x -> x.pmd_loc @@ -987,6 +991,7 @@ end = struct | Pcoerce (t1, t2) -> Option.exists t1 ~f || f t2 ) ) ) | Pexp_let (lbs, _) -> assert (check_let_bindings lbs) | _ -> assert false ) + | Fp _ -> assert false | Lb _ -> assert false | Mb _ -> assert false | Md _ -> assert false @@ -1102,6 +1107,7 @@ end = struct in match (ctx : t) with | Exp _ -> assert false + | Fp _ -> assert false | Lb _ -> assert false | Mb _ -> assert false | Md _ -> assert false @@ -1169,6 +1175,7 @@ end = struct let check_cl {ctx; ast= cl} = match (ctx : t) with | Exp _ -> assert false + | Fp _ -> assert false | Lb _ -> assert false | Mb _ -> assert false | Md _ -> assert false @@ -1288,6 +1295,11 @@ end = struct | _ -> false ) ) | Pexp_for (p, _, _, _, _) | Pexp_fun (_, _, p, _) -> assert (p == pat) ) + | Fp ctx -> + assert ( + match ctx.pparam_desc with + | Pparam_val (_, _, p) -> p == pat + | Pparam_newtype _ -> false ) | Lb x -> assert (x.pvb_pat == pat) | Mb _ -> assert false | Md _ -> assert false @@ -1412,6 +1424,11 @@ end = struct | Pexp_for (_, e1, e2, _, e3) -> assert (e1 == exp || e2 == exp || e3 == exp) | Pexp_override e1N -> assert (List.exists e1N ~f:snd_f) ) + | Fp ctx -> + assert ( + match ctx.pparam_desc with + | Pparam_val (_, e, _) -> Option.exists e ~f:(fun x -> x == exp) + | Pparam_newtype _ -> false ) | Lb x -> assert (x.pvb_expr == exp) | Mb _ -> assert false | Md _ -> assert false @@ -1662,6 +1679,8 @@ end = struct ; ast= ( Pld _ | Top | Tli _ | Pat _ | Cl _ | Mty _ | Mod _ | Sig _ | Str _ | Clf _ | Ctf _ | Rep | Mb _ | Md _ ) } + |{ctx= Fp _; ast= _} + |{ctx= _; ast= Fp _} |{ctx= Lb _; ast= _} |{ctx= _; ast= Lb _} |{ctx= Td _; ast= _} @@ -1745,6 +1764,7 @@ end = struct | Pexp_field _ -> Some Dot | Pexp_send _ -> Some Dot | _ -> None ) + | Fp _ -> None | Lb _ -> None | Cl c -> ( match c.pcl_desc with @@ -1916,7 +1936,10 @@ end = struct | Ppat_variant _ ) ) -> true | (Str _ | Exp _), Ppat_lazy _ -> true - | ( Pat {ppat_desc= Ppat_construct _ | Ppat_variant _; _} + | ( Fp _ + , ( Ppat_tuple _ | Ppat_construct _ | Ppat_alias _ | Ppat_variant _ + | Ppat_lazy _ | Ppat_exception _ | Ppat_or _ ) ) + |( Pat {ppat_desc= Ppat_construct _ | Ppat_variant _; _} , (Ppat_construct (_, Some _) | Ppat_cons _ | Ppat_variant (_, Some _)) ) -> true diff --git a/lib/Ast.mli b/lib/Ast.mli index 2c81d469ae..4897031cc3 100644 --- a/lib/Ast.mli +++ b/lib/Ast.mli @@ -110,6 +110,7 @@ type t = | Cty of class_type | Pat of pattern | Exp of expression + | Fp of function_param | Lb of value_binding | Mb of module_binding | Md of module_declaration diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 70910c9de7..d1a968b406 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1234,29 +1234,30 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) (fmt "@;<0 2>" $ fmt_pattern c (sub_pat ~ctx pat)) ) and fmt_fun_args c args = - let fmt_fun_arg (a : Sugar.arg_kind) = - match a with - | Val + let fmt_fun_arg (a : function_param) = + let ctx = Fp a in + match a.pparam_desc with + | Pparam_val ( ((Labelled l | Optional l) as lbl) - , ( { ast= - { ppat_desc= - ( Ppat_var {txt; loc= _} - | Ppat_constraint - ( { ppat_desc= Ppat_var {txt; loc= _} - ; ppat_attributes= [] - ; _ } - , _ ) ) - ; ppat_attributes= [] - ; _ } - ; _ } as xpat ) - , None ) + , None + , ( { ppat_desc= + ( Ppat_var {txt; loc= _} + | Ppat_constraint + ( { ppat_desc= Ppat_var {txt; loc= _} + ; ppat_attributes= [] + ; _ } + , _ ) ) + ; ppat_attributes= [] + ; _ } as pat ) ) when String.equal l.txt txt -> let symbol = match lbl with Labelled _ -> "~" | _ -> "?" in + let xpat = sub_pat ~ctx pat in cbox 0 (str symbol $ fmt_pattern ~box:true c xpat) - | Val ((Optional _ as lbl), xpat, None) -> - let has_attr = not (List.is_empty xpat.ast.ppat_attributes) in + | Pparam_val ((Optional _ as lbl), None, pat) -> + let xpat = sub_pat ~ctx pat in + let has_attr = not (List.is_empty pat.ppat_attributes) in let outer_parens, inner_parens = - match xpat.ast.ppat_desc with + match pat.ppat_desc with | Ppat_any | Ppat_var _ -> (false, false) | Ppat_unpack _ -> (not has_attr, true) | Ppat_tuple _ -> (false, true) @@ -1268,35 +1269,39 @@ and fmt_fun_args c args = $ hovbox 0 @@ Params.parens_if outer_parens c.conf (fmt_pattern ~parens:inner_parens c xpat) ) - | Val (((Labelled _ | Nolabel) as lbl), xpat, None) -> + | Pparam_val (((Labelled _ | Nolabel) as lbl), None, pat) -> + let xpat = sub_pat ~ctx pat in cbox 2 (fmt_label lbl ":@," $ fmt_pattern c xpat) - | Val + | Pparam_val ( Optional l - , ( { ast= {ppat_desc= Ppat_var {txt; loc= _}; ppat_attributes= []; _} - ; _ } as xpat ) - , Some xexp ) + , Some exp + , ({ppat_desc= Ppat_var {txt; loc= _}; ppat_attributes= []; _} as pat) + ) when String.equal l.txt txt -> + let xexp = sub_exp ~ctx exp in + let xpat = sub_pat ~ctx pat in cbox 0 (wrap "?(" ")" ( fmt_pattern c ~box:true xpat $ fmt " =@;<1 2>" $ hovbox 2 (fmt_expression c xexp) ) ) - | Val + | Pparam_val ( Optional l - , ( { ast= - { ppat_desc= - Ppat_constraint - ({ppat_desc= Ppat_var {txt; loc= _}; _}, _) - ; ppat_attributes= [] - ; _ } - ; _ } as xpat ) - , Some xexp ) + , Some exp + , ( { ppat_desc= + Ppat_constraint ({ppat_desc= Ppat_var {txt; loc= _}; _}, _) + ; ppat_attributes= [] + ; _ } as pat ) ) when String.equal l.txt txt -> + let xexp = sub_exp ~ctx exp in + let xpat = sub_pat ~ctx pat in cbox 0 (wrap "?(" ")" ( fmt_pattern c ~parens:false ~box:true xpat $ fmt " =@;<1 2>" $ fmt_expression c xexp ) ) - | Val (Optional l, xpat, Some xexp) -> + | Pparam_val (Optional l, Some exp, pat) -> + let xexp = sub_exp ~ctx exp in + let xpat = sub_pat ~ctx pat in let parens = match xpat.ast.ppat_desc with | Ppat_unpack _ -> None @@ -1307,10 +1312,10 @@ and fmt_fun_args c args = $ wrap_k (fmt ":@,(") (str ")") ( fmt_pattern c ?parens ~box:true xpat $ fmt " =@;<1 2>" $ fmt_expression c xexp ) ) - | Val ((Labelled _ | Nolabel), _, Some _) -> + | Pparam_val ((Labelled _ | Nolabel), Some _, _) -> impossible "not accepted by parser" - | Newtypes [] -> impossible "not accepted by parser" - | Newtypes names -> + | Pparam_newtype [] -> impossible "not accepted by parser" + | Pparam_newtype names -> cbox 0 (Params.parens c.conf (str "type " $ list names "@ " (fmt_str_loc c)) ) diff --git a/lib/Sugar.ml b/lib/Sugar.ml index fb3c8f2b3f..6f151767f9 100644 --- a/lib/Sugar.ml +++ b/lib/Sugar.ml @@ -14,9 +14,37 @@ open Asttypes open Ast open Extended_ast -type arg_kind = - | Val of arg_label * pattern xt * expression xt option - | Newtypes of string loc list +(* Temporary. Won't be necessary once the type [function_param] is used in + [Pexp_fun] and [Pcl_fun]. *) +let mk_function_param pparam_desc = + let pparam_loc = + let init, locs = + match pparam_desc with + | Pparam_val (lbl, e, p) -> + let locs = + match lbl with + | Nolabel -> [] + | Labelled x -> [x.loc] + | Optional x -> [x.loc] + in + let locs = + match e with Some e -> e.pexp_loc :: locs | None -> locs + in + (p.ppat_loc, locs) + | Pparam_newtype types -> ( + match types with + | [] -> failwith "Pparam_newtype always contains at least one type" + | hd :: tl -> + let locs = List.map tl ~f:(fun x -> x.loc) in + (hd.loc, locs) ) + in + let min acc x = if Location.compare_start acc x < 0 then acc else x in + let max acc x = if Location.compare_end acc x > 0 then acc else x in + let loc_start = (List.fold_left locs ~init ~f:min).loc_start in + let loc_end = (List.fold_left locs ~init ~f:max).loc_end in + {Location.loc_start; loc_end; loc_ghost= true} + in + {pparam_desc; pparam_loc} let fun_ cmts ?(will_keep_first_ast_node = true) xexp = let rec fun_ ?(will_keep_first_ast_node = false) ({ast= exp; _} as xexp) = @@ -29,11 +57,7 @@ let fun_ cmts ?(will_keep_first_ast_node = true) xexp = Cmts.relocate cmts ~src:pexp_loc ~before:pattern.ppat_loc ~after:body.pexp_loc ; let xargs, xbody = fun_ (sub_exp ~ctx body) in - ( Val - ( label - , sub_pat ~ctx pattern - , Option.map default ~f:(sub_exp ~ctx) ) - :: xargs + ( mk_function_param (Pparam_val (label, default, pattern)) :: xargs , xbody ) | Pexp_newtype (name, body) -> if not will_keep_first_ast_node then @@ -42,8 +66,9 @@ let fun_ cmts ?(will_keep_first_ast_node = true) xexp = let xargs, xbody = fun_ (sub_exp ~ctx body) in let xargs = match xargs with - | Newtypes names :: xargs -> Newtypes (name :: names) :: xargs - | xargs -> Newtypes [name] :: xargs + | {pparam_desc= Pparam_newtype names; _} :: xargs -> + mk_function_param (Pparam_newtype (name :: names)) :: xargs + | xargs -> mk_function_param (Pparam_newtype [name]) :: xargs in (xargs, xbody) | _ -> ([], xexp) @@ -62,11 +87,7 @@ let cl_fun ?(will_keep_first_ast_node = true) cmts xexp = Cmts.relocate cmts ~src:pcl_loc ~before:pattern.ppat_loc ~after:body.pcl_loc ; let xargs, xbody = fun_ (sub_cl ~ctx body) in - ( Val - ( label - , sub_pat ~ctx pattern - , Option.map default ~f:(sub_exp ~ctx) ) - :: xargs + ( mk_function_param (Pparam_val (label, default, pattern)) :: xargs , xbody ) | _ -> ([], xexp) else ([], xexp) @@ -220,7 +241,7 @@ module Let_binding = struct type t = { lb_op: string loc ; lb_pat: pattern xt - ; lb_args: arg_kind list + ; lb_args: function_param list ; lb_typ: [ `Polynewtype of label loc list * core_type xt | `Coerce of core_type xt option * core_type xt diff --git a/lib/Sugar.mli b/lib/Sugar.mli index 43eebe2013..f1f5296529 100644 --- a/lib/Sugar.mli +++ b/lib/Sugar.mli @@ -13,15 +13,11 @@ open Migrate_ast open Asttypes open Extended_ast -type arg_kind = - | Val of arg_label * pattern Ast.xt * expression Ast.xt option - | Newtypes of string loc list - val fun_ : Cmts.t -> ?will_keep_first_ast_node:bool -> expression Ast.xt - -> arg_kind list * expression Ast.xt + -> function_param list * expression Ast.xt (** [fun_ cmts will_keep_first_ast_node exp] returns the list of arguments and the body of the function [exp]. [will_keep_first_ast_node] is set by default, otherwise the [exp] is returned without modification. *) @@ -30,7 +26,7 @@ val cl_fun : ?will_keep_first_ast_node:bool -> Cmts.t -> class_expr Ast.xt - -> arg_kind list * class_expr Ast.xt + -> function_param list * class_expr Ast.xt (** [cl_fun will_keep_first_ast_node cmts exp] returns the list of arguments and the body of the function [exp]. [will_keep_first_ast_node] is set by default, otherwise the [exp] is returned without modification. *) @@ -62,7 +58,7 @@ module Let_binding : sig type t = { lb_op: string loc ; lb_pat: pattern Ast.xt - ; lb_args: arg_kind list + ; lb_args: function_param list ; lb_typ: [ `Polynewtype of label loc list * core_type Ast.xt | `Coerce of core_type Ast.xt option * core_type Ast.xt diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index cbf8841c2f..00e1fe4e35 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -467,6 +467,20 @@ end module E = struct (* Value expressions for the core language *) + let map_function_param sub { pparam_loc = loc; pparam_desc = desc } = + let loc = sub.location sub loc in + let desc = + match desc with + | Pparam_val (lab, def, p) -> + Pparam_val + (lab, + map_opt (sub.expr sub) def, + sub.pat sub p) + | Pparam_newtype ty -> + Pparam_newtype (List.map (map_loc sub) ty) + in + { pparam_loc = loc; pparam_desc = desc } + let map_constraint sub c = match c with | Pconstraint ty -> Pconstraint (sub.typ sub ty) diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index 8e3ebfd8a2..f1ec4ec835 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -501,6 +501,38 @@ and binding_op = pbop_loc : Location.t; } +and function_param_desc = + | Pparam_val of arg_label * expression option * 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 loc list + (** [Pparam_newtype x] represents the parameter [(type x y z)]. + [x] carries the location of the identifier, whereas the [pparam_loc] + on the enclosing [function_param] node is the location of the [(type x y z)] + as a whole. + *) + +and function_param = + { + pparam_loc : Location.t; + pparam_desc : function_param_desc; + } + and type_constraint = | Pconstraint of core_type | Pcoerce of core_type option * core_type diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index 28ea03b656..32e671b0b7 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -514,6 +514,18 @@ and if_branch i ppf { if_cond; if_body } = expression i ppf if_cond; expression i ppf if_body +and function_param i ppf { pparam_desc = desc; pparam_loc = loc } = + match desc with + | Pparam_val (l, eo, p) -> + line i ppf "Pparam_val %a\n" fmt_location loc; + arg_label (i+1) ppf l; + option (i+1) expression ppf eo; + pattern (i+1) ppf p + | Pparam_newtype ty -> + line i ppf "Pparam_newtype %a\n" fmt_location loc; + list i (fun i ppf x -> + line (i+1) ppf "type %a" fmt_string_loc x ) ppf ty + and type_constraint i ppf constraint_ = match constraint_ with | Pconstraint ty -> @@ -1219,3 +1231,5 @@ let module_expr ppf x = module_expr 0 ppf x let structure_item ppf x = structure_item 0 ppf x let signature_item ppf x = signature_item 0 ppf x + +let function_param ppf x = function_param 0 ppf x