diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore index 64cd1004a..1e7f6979a 100644 --- a/.ocamlformat-ignore +++ b/.ocamlformat-ignore @@ -18,10 +18,13 @@ astlib/ast_413.ml astlib/ast_414.ml astlib/ast_501.ml -# Files that use cinaps to generate bode blocks from other code blocks work well, +# Files that use cinaps to generate code blocks from other code blocks work well, # but files that inject freely formatted code via cinaps must be excluded ast/versions.ml ast/versions.mli +ast/import.ml +astlib/migrate_414_500.ml +astlib/migrate_500_414.ml # Currently our expect-test lexer is too strict for our expect tests to # work well with ocamlformat diff --git a/CHANGES.md b/CHANGES.md index 20c055b5a..df6471de1 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,19 +1,39 @@ unreleased ------------------- + - raising an exception does no longer cancel the whole context free phase(#453, @burnleydev1) +- Add API to manipulate attributes that are used as flags (#404, @dianaoigo) + +- Update changelog to use ISO 8061 date format: YYYY-MM-DD. (#445, @ceastlund) + +0.31.0 (2023-09-21) +------------------- + +- Fix support for OCaml 5.1: migrated code preserves generative + functor warnings, without creating more. Locations are better + preserved. (#432, @pitag-ha, @panglesd) + - Driver: Add `-unused-code-warnings` command-line flag. (#444, @ceastlund) - Add `?warning` flag to `Deriving.Generator.make`. (#440, @jacksonzou123 via @ceastlund) - Restore the "path_arg" functionality in the V3 API (#431, @ELLIOTTCABLE) -0.30.0 (20/06/2023) +- Expose migration/copying/etc. functions for all AST types needed by `Pprintast` (#454, @antalsz) + +- Preserve quoted attributes on antiquotes in metaquot (#441, @ncik-roberts) + +- Attribute namespaces: Fix semantics of reserving multi-component namespaces (#443, @ncik-roberts) + +0.30.0 (2023-06-20) ------------------- - Adopt the OCaml Code of Conduct on the repo (#426, @pitag-ha) +- Replace `Caml` with `Stdlib`. (#427, @ceastlund) + - Clean up misleading attribute hints when declared for proper context. (#425, @ceastlund) - Ast_pattern now has ebool, pbool helper, and a new map.(#402, @burnleydev1) @@ -41,19 +61,19 @@ unreleased - Add support for OCaml 5.1, excluding OCaml `5.1.0~alpha1` (#428, @shym, @Octachron , @pitag-ha, @panglesd) - Driver: Fix `-locations-check` option for coercions with ground (#428, @Octachron) -0.29.1 (14/02/2023) +0.29.1 (2023-02-14) ------------------ - Allow users to vendor `ppxlib` as-is, as well as `ppx_sexp_conv` in the same project (#386, @kit-ty-kate) -0.29.0 (06/02/2023) +0.29.0 (2023-02-06) ------------------ - Remove `File_path` exports. (#381, @ceastlund) - Add `Ppxlib.Expansion_helpers` with name mangling utilities from ppx_deriving (#370, @sim642) -0.28.0 (05/10/2022) +0.28.0 (2022-10-05) ------------------- - Make `esequence` right-associative. (#366, @ceastlund) @@ -69,7 +89,7 @@ unreleased - Add driver benchmarks (#376, @gridbugs) -0.27.0 (14/06/2022) +0.27.0 (2022-06-14) ------------------- - Update expansion context to leave out value name when multiple are @@ -102,17 +122,17 @@ unreleased - API: For each function that could raise a located error, add a function that return a `result` instead (#329, @panglesd) -0.26.0 (21/03/2022) +0.26.0 (2022-03-21) ------------------- - Bump ppxlib's AST to 4.14/5.00 (#320, @pitag-ha) -0.25.1 (17/06/2022) +0.25.1 (2022-06-17) ------------------- - Add support for OCaml 5.0 (#355, @pitag-ha) -0.25.0 (03/03/2022) +0.25.0 (2022-03-03) ------------------- - Added `error_extensionf` function to the `Location` module (#316, @panglesd) @@ -125,7 +145,7 @@ unreleased - Driver: Append the last valid AST to the error in case of located exception when embedding errors (#315, @panglesd) -0.24.0 (08/12/2021) +0.24.0 (2021-12-08) ------------------- - Add support for OCaml 4.14 (#304, @kit-ty-kate) @@ -147,7 +167,7 @@ unreleased payload (#299, @NathanReb) -0.23.0 (31/08/2021) +0.23.0 (2021-08-31) ------------------- - Drop `Parser` from the API (#263, @pitag-ha) @@ -199,27 +219,27 @@ unreleased - Expose a part of `Ast_io` in order to allow reading AST values from binary files (#270, @arozovyk) -0.22.2 (23/06/2021) +0.22.2 (2021-06-23) ------------------- - Make ppxlib compatible with 4.13 compiler (#260, @kit-ty-kate) -0.22.1 (10/06/2021) +0.22.1 (2021-06-10) ------------------- - Fix location in parse error reporting (#257, @pitag-ha) -0.21.1 (09/06/2021) +0.21.1 (2021-06-09) ------------------- - Fix location in parse error reporting (#256, @pitag-ha) -0.22.0 (04/02/2021) +0.22.0 (2021-02-04) ------------------- - Bump ppxlib's AST to 4.12 (#193, @NathanReb) -0.21.0 (22/01/2021) +0.21.0 (2021-01-22) ------------------- - Fix ppxlib.traverse declaration and make it a deriver and not a rewriter @@ -243,29 +263,29 @@ unreleased - Location.Error: add functions `raise` and `update_loc` (#205, @pitag-ha) -0.20.0 (16/11/2020) +0.20.0 (2020-11-16) ------------------- - Expose `Ppxlib.Driver.map_signature` (#194, @kit-ty-kate) -0.19.0 (23/10/2020) +0.19.0 (2020-10-23) ------------------- - Make ppxlib compatible with 4.12 compiler (#191, @kit-ty-kate) -0.18.0 (06/10/2020) +0.18.0 (2020-10-06) ------------------- - Bump ppxlib's AST to 4.11 (#180, @NathanReb) -0.17.0 (17/09/2020) +0.17.0 (2020-09-17) ------------------- - Add accessors for `code_path` and `tool_name` to `Expansion_context.Base` (#173, @jberdine) - Add `cases` methods to traversal classes in `Ast_traverse` (#183, @pitag-ha) -0.16.0 (18/08/2020) +0.16.0 (2020-08-18) ------------------- - `Driver.register_transformation`: add optional parameter `~instrument` @@ -273,7 +293,7 @@ unreleased - Add missing `Location.init` (#165, @pitag-ha) - Upgrade to ocaml-migrate-parsetree.2.0.0 (#164, @ceastlund) -0.15.0 (04/08/2020) +0.15.0 (2020-08-04) ------------------- - Remove `base` and `stdio` dependencies (#151, @ceastlund) @@ -284,7 +304,7 @@ unreleased - Implement name mangling for `ppxlib_traverse` (#159, @ceastlund) -0.14.0 (08/07/2020) +0.14.0 (2020-07-08) ------------------- - Bump ppxlib's AST to 4.10 (#130, @NathanReb) @@ -296,7 +316,7 @@ unreleased `structure` instead of a `Migrate_parsetree.Driver.some_structure`. (#153, @NathanReb) -0.13.0 (04/15/2020) +0.13.0 (2020-04-15) ------------------- - Add 'metaquot.' prefix to disambiguate metaquote extensions (#121, @@ -305,17 +325,17 @@ unreleased - Bump dune language to 1.11 since the cinaps extension requires at least Dune 1.11 (#126, @diml) -0.12.0 (01/07/2020) +0.12.0 (2020-01-07) ------------------- - Support for OCaml 4.10 (#109, @xclerc) -0.11.0 (01/07/2020) +0.11.0 (2020-01-07) ------------------- - Invariant check on locations (#107, @trefis) -0.10.0 (11/21/2019) +0.10.0 (2019-11-21) ------------------- - Do not produce a suprious empty correction when deriving_inline diff --git a/ast/cinaps/ast_cinaps_helpers.ml b/ast/cinaps/ast_cinaps_helpers.ml index 237c572af..ce120a969 100644 --- a/ast/cinaps/ast_cinaps_helpers.ml +++ b/ast/cinaps/ast_cinaps_helpers.ml @@ -3,33 +3,15 @@ include StdLabels include Printf -let nl () = printf "\n" - -let qualified_types = - [ - ( "Parsetree", - [ - "structure"; - "signature"; - "toplevel_phrase"; - "core_type"; - "expression"; - "pattern"; - "case"; - "type_declaration"; - "type_extension"; - "extension_constructor"; - ] ); - ] +let capitalize_ascii = Stdppx.String.capitalize_ascii +(* Reexports from [Astlib_cinaps_helpers] *) +let nl = Astlib_cinaps_helpers.nl +let qualified_types = Astlib_cinaps_helpers.qualified_types +let foreach_module = Astlib_cinaps_helpers.foreach_module +let foreach_type = Astlib_cinaps_helpers.foreach_type let all_types = List.concat (List.map ~f:snd qualified_types) -let foreach_module f = - nl (); - List.iter qualified_types ~f:(fun (m, types) -> f m types) - -let foreach_type f = foreach_module (fun m -> List.iter ~f:(f m)) - let foreach_version f = nl (); List.iter Supported_version.all ~f:(fun v -> diff --git a/ast/cinaps/dune b/ast/cinaps/dune index 0b5e453a8..4ece19d35 100644 --- a/ast/cinaps/dune +++ b/ast/cinaps/dune @@ -1,3 +1,3 @@ (library (name ast_cinaps_helpers) - (libraries supported_version)) + (libraries stdppx supported_version astlib_cinaps_helpers)) diff --git a/ast/import.ml b/ast/import.ml index 7ed293b81..57168b7fd 100644 --- a/ast/import.ml +++ b/ast/import.ml @@ -4,6 +4,8 @@ It must be opened in all modules, especially the ones coming from the compiler. *) +(*$ open Ast_cinaps_helpers $*) + module Js = Versions.OCaml_500 module Ocaml = Versions.OCaml_current @@ -12,18 +14,43 @@ module Select_ast (Ocaml : Versions.OCaml_version) = struct module Type = struct type ('js, 'ocaml) t = - | Signature - : (Js.Ast.Parsetree.signature, Ocaml.Ast.Parsetree.signature) t + (*$ foreach_type (fun _ s -> + printf + " | %s\n\ + \ : ( Js.Ast.Parsetree.%s,\n\ + \ Ocaml.Ast.Parsetree.%s )\n\ + \ t\n" + (capitalize_ascii s) s s + ) + *) | Structure - : (Js.Ast.Parsetree.structure, Ocaml.Ast.Parsetree.structure) t + : ( Js.Ast.Parsetree.structure, + Ocaml.Ast.Parsetree.structure ) + t + | Signature + : ( Js.Ast.Parsetree.signature, + Ocaml.Ast.Parsetree.signature ) + t | Toplevel_phrase : ( Js.Ast.Parsetree.toplevel_phrase, Ocaml.Ast.Parsetree.toplevel_phrase ) t - | Expression - : (Js.Ast.Parsetree.expression, Ocaml.Ast.Parsetree.expression) t | Core_type - : (Js.Ast.Parsetree.core_type, Ocaml.Ast.Parsetree.core_type) t + : ( Js.Ast.Parsetree.core_type, + Ocaml.Ast.Parsetree.core_type ) + t + | Expression + : ( Js.Ast.Parsetree.expression, + Ocaml.Ast.Parsetree.expression ) + t + | Pattern + : ( Js.Ast.Parsetree.pattern, + Ocaml.Ast.Parsetree.pattern ) + t + | Case + : ( Js.Ast.Parsetree.case, + Ocaml.Ast.Parsetree.case ) + t | Type_declaration : ( Js.Ast.Parsetree.type_declaration, Ocaml.Ast.Parsetree.type_declaration ) @@ -36,6 +63,43 @@ module Select_ast (Ocaml : Versions.OCaml_version) = struct : ( Js.Ast.Parsetree.extension_constructor, Ocaml.Ast.Parsetree.extension_constructor ) t + | Class_expr + : ( Js.Ast.Parsetree.class_expr, + Ocaml.Ast.Parsetree.class_expr ) + t + | Class_field + : ( Js.Ast.Parsetree.class_field, + Ocaml.Ast.Parsetree.class_field ) + t + | Class_type + : ( Js.Ast.Parsetree.class_type, + Ocaml.Ast.Parsetree.class_type ) + t + | Class_signature + : ( Js.Ast.Parsetree.class_signature, + Ocaml.Ast.Parsetree.class_signature ) + t + | Class_type_field + : ( Js.Ast.Parsetree.class_type_field, + Ocaml.Ast.Parsetree.class_type_field ) + t + | Module_expr + : ( Js.Ast.Parsetree.module_expr, + Ocaml.Ast.Parsetree.module_expr ) + t + | Module_type + : ( Js.Ast.Parsetree.module_type, + Ocaml.Ast.Parsetree.module_type ) + t + | Signature_item + : ( Js.Ast.Parsetree.signature_item, + Ocaml.Ast.Parsetree.signature_item ) + t + | Structure_item + : ( Js.Ast.Parsetree.structure_item, + Ocaml.Ast.Parsetree.structure_item ) + t +(*$*) | List : ('a, 'b) t -> ('a list, 'b list) t | Pair : ('a, 'b) t * ('c, 'd) t -> ('a * 'c, 'b * 'd) t end @@ -48,14 +112,32 @@ module Select_ast (Ocaml : Versions.OCaml_version) = struct let open Of_ocaml in fun node -> match node with - | Signature -> copy_signature + (*$ foreach_type (fun _ s -> + printf + " | %s -> copy_%s\n" + (capitalize_ascii s) s + ) + *) | Structure -> copy_structure + | Signature -> copy_signature | Toplevel_phrase -> copy_toplevel_phrase - | Expression -> copy_expression | Core_type -> copy_core_type + | Expression -> copy_expression + | Pattern -> copy_pattern + | Case -> copy_case | Type_declaration -> copy_type_declaration | Type_extension -> copy_type_extension | Extension_constructor -> copy_extension_constructor + | Class_expr -> copy_class_expr + | Class_field -> copy_class_field + | Class_type -> copy_class_type + | Class_signature -> copy_class_signature + | Class_type_field -> copy_class_type_field + | Module_expr -> copy_module_expr + | Module_type -> copy_module_type + | Signature_item -> copy_signature_item + | Structure_item -> copy_structure_item +(*$*) | List t -> List.map (of_ocaml t) | Pair (a, b) -> let f = of_ocaml a in @@ -66,14 +148,32 @@ module Select_ast (Ocaml : Versions.OCaml_version) = struct let open To_ocaml in fun node -> match node with - | Signature -> copy_signature + (*$ foreach_type (fun _ s -> + printf + " | %s -> copy_%s\n" + (capitalize_ascii s) s + ) + *) | Structure -> copy_structure + | Signature -> copy_signature | Toplevel_phrase -> copy_toplevel_phrase - | Expression -> copy_expression | Core_type -> copy_core_type + | Expression -> copy_expression + | Pattern -> copy_pattern + | Case -> copy_case | Type_declaration -> copy_type_declaration | Type_extension -> copy_type_extension | Extension_constructor -> copy_extension_constructor + | Class_expr -> copy_class_expr + | Class_field -> copy_class_field + | Class_type -> copy_class_type + | Class_signature -> copy_class_signature + | Class_type_field -> copy_class_type_field + | Module_expr -> copy_module_expr + | Module_type -> copy_module_type + | Signature_item -> copy_signature_item + | Structure_item -> copy_structure_item +(*$*) | List t -> List.map (to_ocaml t) | Pair (a, b) -> let f = to_ocaml a in diff --git a/ast/versions.ml b/ast/versions.ml index cf7bb2081..58598030b 100644 --- a/ast/versions.ml +++ b/ast/versions.ml @@ -46,6 +46,15 @@ module type Ast = sig type type_declaration type type_extension type extension_constructor + type class_expr + type class_field + type class_type + type class_signature + type class_type_field + type module_expr + type module_type + type signature_item + type structure_item end (*$*) module Config : sig @@ -69,6 +78,15 @@ type 'a _types = 'a constraint 'a type_declaration : _; type_extension : _; extension_constructor : _; + class_expr : _; + class_field : _; + class_type : _; + class_signature : _; + class_type_field : _; + module_expr : _; + module_type : _; + signature_item : _; + structure_item : _; (*$*) > ;; @@ -97,6 +115,24 @@ type 'a get_type_extension = 'x constraint 'a _types = < type_extension : 'x; .. > type 'a get_extension_constructor = 'x constraint 'a _types = < extension_constructor : 'x; .. > +type 'a get_class_expr = + 'x constraint 'a _types = < class_expr : 'x; .. > +type 'a get_class_field = + 'x constraint 'a _types = < class_field : 'x; .. > +type 'a get_class_type = + 'x constraint 'a _types = < class_type : 'x; .. > +type 'a get_class_signature = + 'x constraint 'a _types = < class_signature : 'x; .. > +type 'a get_class_type_field = + 'x constraint 'a _types = < class_type_field : 'x; .. > +type 'a get_module_expr = + 'x constraint 'a _types = < module_expr : 'x; .. > +type 'a get_module_type = + 'x constraint 'a _types = < module_type : 'x; .. > +type 'a get_signature_item = + 'x constraint 'a _types = < signature_item : 'x; .. > +type 'a get_structure_item = + 'x constraint 'a _types = < structure_item : 'x; .. > (*$*) module type OCaml_version = sig @@ -115,6 +151,15 @@ module type OCaml_version = sig type_declaration : Ast.Parsetree.type_declaration; type_extension : Ast.Parsetree.type_extension; extension_constructor : Ast.Parsetree.extension_constructor; + class_expr : Ast.Parsetree.class_expr; + class_field : Ast.Parsetree.class_field; + class_type : Ast.Parsetree.class_type; + class_signature : Ast.Parsetree.class_signature; + class_type_field : Ast.Parsetree.class_type_field; + module_expr : Ast.Parsetree.module_expr; + module_type : Ast.Parsetree.module_type; + signature_item : Ast.Parsetree.signature_item; + structure_item : Ast.Parsetree.structure_item; (*$*) > _types type _ witnesses += Version : types witnesses @@ -135,6 +180,15 @@ struct type_declaration : Ast.Parsetree.type_declaration; type_extension : Ast.Parsetree.type_extension; extension_constructor : Ast.Parsetree.extension_constructor; + class_expr : Ast.Parsetree.class_expr; + class_field : Ast.Parsetree.class_field; + class_type : Ast.Parsetree.class_type; + class_signature : Ast.Parsetree.class_signature; + class_type_field : Ast.Parsetree.class_type_field; + module_expr : Ast.Parsetree.module_expr; + module_type : Ast.Parsetree.module_type; + signature_item : Ast.Parsetree.signature_item; + structure_item : Ast.Parsetree.structure_item; (*$*) > _types type _ witnesses += Version : types witnesses @@ -157,6 +211,15 @@ type 'types ocaml_version = and type Ast.Parsetree.type_declaration = 'types get_type_declaration and type Ast.Parsetree.type_extension = 'types get_type_extension and type Ast.Parsetree.extension_constructor = 'types get_extension_constructor + and type Ast.Parsetree.class_expr = 'types get_class_expr + and type Ast.Parsetree.class_field = 'types get_class_field + and type Ast.Parsetree.class_type = 'types get_class_type + and type Ast.Parsetree.class_signature = 'types get_class_signature + and type Ast.Parsetree.class_type_field = 'types get_class_type_field + and type Ast.Parsetree.module_expr = 'types get_module_expr + and type Ast.Parsetree.module_type = 'types get_module_type + and type Ast.Parsetree.signature_item = 'types get_signature_item + and type Ast.Parsetree.structure_item = 'types get_structure_item (*$*) ) @@ -173,6 +236,15 @@ type ('from, 'to_) migration_functions = { copy_type_declaration: 'from get_type_declaration -> 'to_ get_type_declaration; copy_type_extension: 'from get_type_extension -> 'to_ get_type_extension; copy_extension_constructor: 'from get_extension_constructor -> 'to_ get_extension_constructor; + copy_class_expr: 'from get_class_expr -> 'to_ get_class_expr; + copy_class_field: 'from get_class_field -> 'to_ get_class_field; + copy_class_type: 'from get_class_type -> 'to_ get_class_type; + copy_class_signature: 'from get_class_signature -> 'to_ get_class_signature; + copy_class_type_field: 'from get_class_type_field -> 'to_ get_class_type_field; + copy_module_expr: 'from get_module_expr -> 'to_ get_module_expr; + copy_module_type: 'from get_module_type -> 'to_ get_module_type; + copy_signature_item: 'from get_signature_item -> 'to_ get_signature_item; + copy_structure_item: 'from get_structure_item -> 'to_ get_structure_item; (*$*) } @@ -189,6 +261,15 @@ let migration_identity : ('a, 'a) migration_functions = { copy_type_declaration = id; copy_type_extension = id; copy_extension_constructor = id; + copy_class_expr = id; + copy_class_field = id; + copy_class_type = id; + copy_class_signature = id; + copy_class_type_field = id; + copy_module_expr = id; + copy_module_type = id; + copy_signature_item = id; + copy_structure_item = id; (*$*) } @@ -206,6 +287,15 @@ let migration_compose (ab : ('a, 'b) migration_functions) (bc : ('b, 'c) migrati copy_type_declaration = compose bc.copy_type_declaration ab.copy_type_declaration; copy_type_extension = compose bc.copy_type_extension ab.copy_type_extension; copy_extension_constructor = compose bc.copy_extension_constructor ab.copy_extension_constructor; + copy_class_expr = compose bc.copy_class_expr ab.copy_class_expr; + copy_class_field = compose bc.copy_class_field ab.copy_class_field; + copy_class_type = compose bc.copy_class_type ab.copy_class_type; + copy_class_signature = compose bc.copy_class_signature ab.copy_class_signature; + copy_class_type_field = compose bc.copy_class_type_field ab.copy_class_type_field; + copy_module_expr = compose bc.copy_module_expr ab.copy_module_expr; + copy_module_type = compose bc.copy_module_type ab.copy_module_type; + copy_signature_item = compose bc.copy_signature_item ab.copy_signature_item; + copy_structure_item = compose bc.copy_structure_item ab.copy_structure_item; (*$*) } @@ -226,6 +316,15 @@ module type Migrate_module = sig val copy_type_declaration : From.Parsetree.type_declaration -> To.Parsetree.type_declaration val copy_type_extension : From.Parsetree.type_extension -> To.Parsetree.type_extension val copy_extension_constructor: From.Parsetree.extension_constructor -> To.Parsetree.extension_constructor + val copy_class_expr : From.Parsetree.class_expr -> To.Parsetree.class_expr + val copy_class_field : From.Parsetree.class_field -> To.Parsetree.class_field + val copy_class_type : From.Parsetree.class_type -> To.Parsetree.class_type + val copy_class_signature : From.Parsetree.class_signature -> To.Parsetree.class_signature + val copy_class_type_field : From.Parsetree.class_type_field -> To.Parsetree.class_type_field + val copy_module_expr : From.Parsetree.module_expr -> To.Parsetree.module_expr + val copy_module_type : From.Parsetree.module_type -> To.Parsetree.module_type + val copy_signature_item : From.Parsetree.signature_item -> To.Parsetree.signature_item + val copy_structure_item : From.Parsetree.structure_item -> To.Parsetree.structure_item (*$*) end @@ -248,6 +347,15 @@ struct copy_type_declaration; copy_type_extension; copy_extension_constructor; + copy_class_expr; + copy_class_field; + copy_class_type; + copy_class_signature; + copy_class_type_field; + copy_module_expr; + copy_module_type; + copy_signature_item; + copy_structure_item; (*$*) } end @@ -292,6 +400,15 @@ let immediate_migration (type type_declaration) (type type_extension) (type extension_constructor) + (type class_expr) + (type class_field) + (type class_type) + (type class_signature) + (type class_type_field) + (type module_expr) + (type module_type) + (type signature_item) + (type structure_item) (*$*) ((module A) : < (*$ foreach_type (fun _ s -> printf " %-21s : %s;\n" s s) *) @@ -305,6 +422,15 @@ let immediate_migration type_declaration : type_declaration; type_extension : type_extension; extension_constructor : extension_constructor; + class_expr : class_expr; + class_field : class_field; + class_type : class_type; + class_signature : class_signature; + class_type_field : class_type_field; + module_expr : module_expr; + module_type : module_type; + signature_item : signature_item; + structure_item : structure_item; (*$*) > ocaml_version) direction @@ -330,6 +456,15 @@ let migrate (type type_declaration1) (type type_declaration2) (type type_extension1) (type type_extension2) (type extension_constructor1) (type extension_constructor2) + (type class_expr1) (type class_expr2) + (type class_field1) (type class_field2) + (type class_type1) (type class_type2) + (type class_signature1) (type class_signature2) + (type class_type_field1) (type class_type_field2) + (type module_expr1) (type module_expr2) + (type module_type1) (type module_type2) + (type signature_item1) (type signature_item2) + (type structure_item1) (type structure_item2) (*$*) ((module A) : < (*$ foreach_type (fun _ s -> printf " %-21s : %s1;\n" s s) *) @@ -343,6 +478,15 @@ let migrate type_declaration : type_declaration1; type_extension : type_extension1; extension_constructor : extension_constructor1; + class_expr : class_expr1; + class_field : class_field1; + class_type : class_type1; + class_signature : class_signature1; + class_type_field : class_type_field1; + module_expr : module_expr1; + module_type : module_type1; + signature_item : signature_item1; + structure_item : structure_item1; (*$*) > ocaml_version) ((module B) : < @@ -357,6 +501,15 @@ let migrate type_declaration : type_declaration2; type_extension : type_extension2; extension_constructor : extension_constructor2; + class_expr : class_expr2; + class_field : class_field2; + class_type : class_type2; + class_signature : class_signature2; + class_type_field : class_type_field2; + module_expr : module_expr2; + module_type : module_type2; + signature_item : signature_item2; + structure_item : structure_item2; (*$*) > ocaml_version) : (A.types, B.types) migration_functions @@ -392,6 +545,15 @@ module Convert (A : OCaml_version) (B : OCaml_version) = struct copy_type_declaration; copy_type_extension; copy_extension_constructor; + copy_class_expr; + copy_class_field; + copy_class_type; + copy_class_signature; + copy_class_type_field; + copy_module_expr; + copy_module_type; + copy_signature_item; + copy_structure_item; (*$*) } : (A.types, B.types) migration_functions = migrate (module A) (module B) diff --git a/ast/versions.mli b/ast/versions.mli index 83b2ea78f..782c0a856 100644 --- a/ast/versions.mli +++ b/ast/versions.mli @@ -37,6 +37,15 @@ module type Ast = sig type type_declaration type type_extension type extension_constructor + type class_expr + type class_field + type class_type + type class_signature + type class_type_field + type module_expr + type module_type + type signature_item + type structure_item end (*$*) module Config : sig @@ -60,6 +69,15 @@ type 'a _types = 'a constraint 'a type_declaration : _; type_extension : _; extension_constructor : _; + class_expr : _; + class_field : _; + class_type : _; + class_signature : _; + class_type_field : _; + module_expr : _; + module_type : _; + signature_item : _; + structure_item : _; (*$*) > ;; @@ -98,6 +116,15 @@ module type OCaml_version = sig type_declaration : Ast.Parsetree.type_declaration; type_extension : Ast.Parsetree.type_extension; extension_constructor : Ast.Parsetree.extension_constructor; + class_expr : Ast.Parsetree.class_expr; + class_field : Ast.Parsetree.class_field; + class_type : Ast.Parsetree.class_type; + class_signature : Ast.Parsetree.class_signature; + class_type_field : Ast.Parsetree.class_type_field; + module_expr : Ast.Parsetree.module_expr; + module_type : Ast.Parsetree.module_type; + signature_item : Ast.Parsetree.signature_item; + structure_item : Ast.Parsetree.structure_item; (*$*) > _types @@ -155,6 +182,15 @@ module Convert (A : OCaml_version) (B : OCaml_version) : sig val copy_type_declaration : A.Ast.Parsetree.type_declaration -> B.Ast.Parsetree.type_declaration val copy_type_extension : A.Ast.Parsetree.type_extension -> B.Ast.Parsetree.type_extension val copy_extension_constructor : A.Ast.Parsetree.extension_constructor -> B.Ast.Parsetree.extension_constructor + val copy_class_expr : A.Ast.Parsetree.class_expr -> B.Ast.Parsetree.class_expr + val copy_class_field : A.Ast.Parsetree.class_field -> B.Ast.Parsetree.class_field + val copy_class_type : A.Ast.Parsetree.class_type -> B.Ast.Parsetree.class_type + val copy_class_signature : A.Ast.Parsetree.class_signature -> B.Ast.Parsetree.class_signature + val copy_class_type_field : A.Ast.Parsetree.class_type_field -> B.Ast.Parsetree.class_type_field + val copy_module_expr : A.Ast.Parsetree.module_expr -> B.Ast.Parsetree.module_expr + val copy_module_type : A.Ast.Parsetree.module_type -> B.Ast.Parsetree.module_type + val copy_signature_item : A.Ast.Parsetree.signature_item -> B.Ast.Parsetree.signature_item + val copy_structure_item : A.Ast.Parsetree.structure_item -> B.Ast.Parsetree.structure_item (*$*) end diff --git a/astlib/cinaps/astlib_cinaps_helpers.ml b/astlib/cinaps/astlib_cinaps_helpers.ml index 550c84021..7760b4fd8 100644 --- a/astlib/cinaps/astlib_cinaps_helpers.ml +++ b/astlib/cinaps/astlib_cinaps_helpers.ml @@ -37,3 +37,37 @@ let foreach_version_pair f = | [ _ ] | [] -> () in aux supported_versions + +(* Just for 4.14 <-> 5.00, mostly used by [ast_cinaps_helpers] *) + +let qualified_types = + [ + ( "Parsetree", + [ + "structure"; + "signature"; + "toplevel_phrase"; + "core_type"; + "expression"; + "pattern"; + "case"; + "type_declaration"; + "type_extension"; + "extension_constructor"; + "class_expr"; + "class_field"; + "class_type"; + "class_signature"; + "class_type_field"; + "module_expr"; + "module_type"; + "signature_item"; + "structure_item"; + ] ); + ] + +let foreach_module f = + nl (); + List.iter qualified_types ~f:(fun (m, types) -> f m types) + +let foreach_type f = foreach_module (fun m -> List.iter ~f:(f m)) diff --git a/astlib/migrate_414_500.ml b/astlib/migrate_414_500.ml index 6a81b0736..084692807 100644 --- a/astlib/migrate_414_500.ml +++ b/astlib/migrate_414_500.ml @@ -1,40 +1,90 @@ module From = Ast_414 module To = Ast_500 -let copy_structure : Ast_414.Parsetree.structure -> Ast_500.Parsetree.structure - = - fun x -> x +(*$ open Astlib_cinaps_helpers $*) -let copy_signature : Ast_414.Parsetree.signature -> Ast_500.Parsetree.signature - = - fun x -> x +(*$ foreach_type (fun _ s -> + Printf.printf + "let copy_%s\n\ + \ : Ast_414.Parsetree.%s -> Ast_500.Parsetree.%s\n\ + \ = fun x -> x\n\n" + s s s + ) +*) +let copy_structure + : Ast_414.Parsetree.structure -> Ast_500.Parsetree.structure + = fun x -> x -let copy_toplevel_phrase : - Ast_414.Parsetree.toplevel_phrase -> Ast_500.Parsetree.toplevel_phrase = - fun x -> x +let copy_signature + : Ast_414.Parsetree.signature -> Ast_500.Parsetree.signature + = fun x -> x -let copy_core_type : Ast_414.Parsetree.core_type -> Ast_500.Parsetree.core_type - = - fun x -> x +let copy_toplevel_phrase + : Ast_414.Parsetree.toplevel_phrase -> Ast_500.Parsetree.toplevel_phrase + = fun x -> x -let copy_expression : - Ast_414.Parsetree.expression -> Ast_500.Parsetree.expression = - fun x -> x +let copy_core_type + : Ast_414.Parsetree.core_type -> Ast_500.Parsetree.core_type + = fun x -> x -let copy_pattern : Ast_414.Parsetree.pattern -> Ast_500.Parsetree.pattern = - fun x -> x +let copy_expression + : Ast_414.Parsetree.expression -> Ast_500.Parsetree.expression + = fun x -> x -let copy_case : Ast_414.Parsetree.case -> Ast_500.Parsetree.case = fun x -> x +let copy_pattern + : Ast_414.Parsetree.pattern -> Ast_500.Parsetree.pattern + = fun x -> x -let copy_type_declaration : - Ast_414.Parsetree.type_declaration -> Ast_500.Parsetree.type_declaration = - fun x -> x +let copy_case + : Ast_414.Parsetree.case -> Ast_500.Parsetree.case + = fun x -> x -let copy_type_extension : - Ast_414.Parsetree.type_extension -> Ast_500.Parsetree.type_extension = - fun x -> x +let copy_type_declaration + : Ast_414.Parsetree.type_declaration -> Ast_500.Parsetree.type_declaration + = fun x -> x -let copy_extension_constructor : - Ast_414.Parsetree.extension_constructor -> - Ast_500.Parsetree.extension_constructor = - fun x -> x +let copy_type_extension + : Ast_414.Parsetree.type_extension -> Ast_500.Parsetree.type_extension + = fun x -> x + +let copy_extension_constructor + : Ast_414.Parsetree.extension_constructor -> Ast_500.Parsetree.extension_constructor + = fun x -> x + +let copy_class_expr + : Ast_414.Parsetree.class_expr -> Ast_500.Parsetree.class_expr + = fun x -> x + +let copy_class_field + : Ast_414.Parsetree.class_field -> Ast_500.Parsetree.class_field + = fun x -> x + +let copy_class_type + : Ast_414.Parsetree.class_type -> Ast_500.Parsetree.class_type + = fun x -> x + +let copy_class_signature + : Ast_414.Parsetree.class_signature -> Ast_500.Parsetree.class_signature + = fun x -> x + +let copy_class_type_field + : Ast_414.Parsetree.class_type_field -> Ast_500.Parsetree.class_type_field + = fun x -> x + +let copy_module_expr + : Ast_414.Parsetree.module_expr -> Ast_500.Parsetree.module_expr + = fun x -> x + +let copy_module_type + : Ast_414.Parsetree.module_type -> Ast_500.Parsetree.module_type + = fun x -> x + +let copy_signature_item + : Ast_414.Parsetree.signature_item -> Ast_500.Parsetree.signature_item + = fun x -> x + +let copy_structure_item + : Ast_414.Parsetree.structure_item -> Ast_500.Parsetree.structure_item + = fun x -> x + +(*$*) diff --git a/astlib/migrate_500_414.ml b/astlib/migrate_500_414.ml index ac0f27bdc..6b625e209 100644 --- a/astlib/migrate_500_414.ml +++ b/astlib/migrate_500_414.ml @@ -1,40 +1,90 @@ module From = Ast_500 module To = Ast_414 -let copy_structure : Ast_500.Parsetree.structure -> Ast_414.Parsetree.structure - = - fun x -> x +(*$ open Astlib_cinaps_helpers $*) -let copy_signature : Ast_500.Parsetree.signature -> Ast_414.Parsetree.signature - = - fun x -> x +(*$ foreach_type (fun _ s -> + Printf.printf + "let copy_%s\n\ + \ : Ast_500.Parsetree.%s -> Ast_414.Parsetree.%s\n\ + \ = fun x -> x\n\n" + s s s + ) +*) +let copy_structure + : Ast_500.Parsetree.structure -> Ast_414.Parsetree.structure + = fun x -> x -let copy_toplevel_phrase : - Ast_500.Parsetree.toplevel_phrase -> Ast_414.Parsetree.toplevel_phrase = - fun x -> x +let copy_signature + : Ast_500.Parsetree.signature -> Ast_414.Parsetree.signature + = fun x -> x -let copy_core_type : Ast_500.Parsetree.core_type -> Ast_414.Parsetree.core_type - = - fun x -> x +let copy_toplevel_phrase + : Ast_500.Parsetree.toplevel_phrase -> Ast_414.Parsetree.toplevel_phrase + = fun x -> x -let copy_expression : - Ast_500.Parsetree.expression -> Ast_414.Parsetree.expression = - fun x -> x +let copy_core_type + : Ast_500.Parsetree.core_type -> Ast_414.Parsetree.core_type + = fun x -> x -let copy_pattern : Ast_500.Parsetree.pattern -> Ast_414.Parsetree.pattern = - fun x -> x +let copy_expression + : Ast_500.Parsetree.expression -> Ast_414.Parsetree.expression + = fun x -> x -let copy_case : Ast_500.Parsetree.case -> Ast_414.Parsetree.case = fun x -> x +let copy_pattern + : Ast_500.Parsetree.pattern -> Ast_414.Parsetree.pattern + = fun x -> x -let copy_type_declaration : - Ast_500.Parsetree.type_declaration -> Ast_414.Parsetree.type_declaration = - fun x -> x +let copy_case + : Ast_500.Parsetree.case -> Ast_414.Parsetree.case + = fun x -> x -let copy_type_extension : - Ast_500.Parsetree.type_extension -> Ast_414.Parsetree.type_extension = - fun x -> x +let copy_type_declaration + : Ast_500.Parsetree.type_declaration -> Ast_414.Parsetree.type_declaration + = fun x -> x -let copy_extension_constructor : - Ast_500.Parsetree.extension_constructor -> - Ast_414.Parsetree.extension_constructor = - fun x -> x +let copy_type_extension + : Ast_500.Parsetree.type_extension -> Ast_414.Parsetree.type_extension + = fun x -> x + +let copy_extension_constructor + : Ast_500.Parsetree.extension_constructor -> Ast_414.Parsetree.extension_constructor + = fun x -> x + +let copy_class_expr + : Ast_500.Parsetree.class_expr -> Ast_414.Parsetree.class_expr + = fun x -> x + +let copy_class_field + : Ast_500.Parsetree.class_field -> Ast_414.Parsetree.class_field + = fun x -> x + +let copy_class_type + : Ast_500.Parsetree.class_type -> Ast_414.Parsetree.class_type + = fun x -> x + +let copy_class_signature + : Ast_500.Parsetree.class_signature -> Ast_414.Parsetree.class_signature + = fun x -> x + +let copy_class_type_field + : Ast_500.Parsetree.class_type_field -> Ast_414.Parsetree.class_type_field + = fun x -> x + +let copy_module_expr + : Ast_500.Parsetree.module_expr -> Ast_414.Parsetree.module_expr + = fun x -> x + +let copy_module_type + : Ast_500.Parsetree.module_type -> Ast_414.Parsetree.module_type + = fun x -> x + +let copy_signature_item + : Ast_500.Parsetree.signature_item -> Ast_414.Parsetree.signature_item + = fun x -> x + +let copy_structure_item + : Ast_500.Parsetree.structure_item -> Ast_414.Parsetree.structure_item + = fun x -> x + +(*$*) diff --git a/astlib/migrate_500_501.ml b/astlib/migrate_500_501.ml index bb26e4f38..c3cd1499e 100644 --- a/astlib/migrate_500_501.ml +++ b/astlib/migrate_500_501.ml @@ -751,7 +751,27 @@ and copy_module_expr_desc : Ast_501.Parsetree.Pmod_functor (copy_functor_parameter x0, copy_module_expr x1) | Ast_500.Parsetree.Pmod_apply (x0, x1) -> - Ast_501.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + let x1, is_unit = + match x1.pmod_desc with + | Pmod_structure [] -> + let rec extract_attr acc : Ast_500.Parsetree.attributes -> _ = + function + | [] -> (List.rev acc, true) + | { + attr_name = { txt = "ppxlib.migration.keep_structure"; _ }; + _; + } + :: q -> + (List.rev_append acc q, false) + | hd :: tl -> extract_attr (hd :: acc) tl + in + let pmod_attributes, b = extract_attr [] x1.pmod_attributes in + ({ x1 with pmod_attributes }, b) + | _ -> (x1, false) + in + if is_unit then Ast_501.Parsetree.Pmod_apply_unit (copy_module_expr x0) + else + Ast_501.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) | Ast_500.Parsetree.Pmod_constraint (x0, x1) -> Ast_501.Parsetree.Pmod_constraint (copy_module_expr x0, copy_module_type x1) diff --git a/astlib/migrate_501_500.ml b/astlib/migrate_501_500.ml index ac53b3203..a0a776e1c 100644 --- a/astlib/migrate_501_500.ml +++ b/astlib/migrate_501_500.ml @@ -770,13 +770,14 @@ and copy_module_expr : Ast_501.Parsetree.pmod_loc; Ast_501.Parsetree.pmod_attributes; } -> + let loc = copy_location pmod_loc in { - Ast_500.Parsetree.pmod_desc = copy_module_expr_desc pmod_desc; - Ast_500.Parsetree.pmod_loc = copy_location pmod_loc; + Ast_500.Parsetree.pmod_desc = copy_module_expr_desc loc pmod_desc; + Ast_500.Parsetree.pmod_loc = loc; Ast_500.Parsetree.pmod_attributes = copy_attributes pmod_attributes; } -and copy_module_expr_desc : +and copy_module_expr_desc loc : Ast_501.Parsetree.module_expr_desc -> Ast_500.Parsetree.module_expr_desc = function | Ast_501.Parsetree.Pmod_ident x0 -> @@ -787,13 +788,30 @@ and copy_module_expr_desc : Ast_500.Parsetree.Pmod_functor (copy_functor_parameter x0, copy_module_expr x1) | Ast_501.Parsetree.Pmod_apply (x0, x1) -> - Ast_500.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1) + let x1 = copy_module_expr x1 in + let x1 = + match x1.pmod_desc with + | Pmod_structure [] -> + let loc = { x1.pmod_loc with loc_ghost = true } in + let pmod_attributes = + { + Ast_500.Parsetree.attr_name = + { txt = "ppxlib.migration.keep_structure"; loc }; + attr_payload = Ast_500.Parsetree.PStr []; + attr_loc = loc; + } + :: x1.pmod_attributes + in + { x1 with pmod_attributes } + | _ -> x1 + in + Ast_500.Parsetree.Pmod_apply (copy_module_expr x0, x1) | Ast_501.Parsetree.Pmod_apply_unit x0 -> let empty_struct = Ast_500.Parsetree. { pmod_desc = Pmod_structure []; - pmod_loc = Location.none; + pmod_loc = loc; pmod_attributes = []; } in diff --git a/bench/drivers/identity/inputs/bap_knowledge.ml b/bench/drivers/identity/inputs/bap_knowledge.ml index c3621dd8c..ba7e05881 100644 --- a/bench/drivers/identity/inputs/bap_knowledge.ml +++ b/bench/drivers/identity/inputs/bap_knowledge.ml @@ -24,9 +24,9 @@ type conflict = exn = .. module Conflict = struct type t = conflict = .. - let to_string = Caml.Printexc.to_string + let to_string = Stdlib.Printexc.to_string let pp ppf err = Format.fprintf ppf "%s" (to_string err) - let register_printer = Caml.Printexc.register_printer + let register_printer = Stdlib.Printexc.register_printer let sexp_of_t err = Sexp.Atom (to_string err) end @@ -153,22 +153,22 @@ end = struct let rec find_exn t k = match t with - | Nil -> raise Caml.Not_found + | Nil -> raise Stdlib.Not_found | Tip (k', v) when k = k' -> v - | Tip _ -> raise Caml.Not_found + | Tip _ -> raise Stdlib.Not_found | Bin (k', l, r) -> ( match Key.compare k' k with - | NA -> raise Caml.Not_found + | NA -> raise Stdlib.Not_found | LB -> find_exn l k | RB -> find_exn r k) - let find t k = try Some (find_exn t k) with Caml.Not_found -> None + let find t k = try Some (find_exn t k) with Stdlib.Not_found -> None let mem k t = try ignore (find_exn k t); true - with Caml.Not_found -> false + with Stdlib.Not_found -> false let node payload branching l r = match (l, r) with @@ -359,7 +359,7 @@ end = struct let unescaped_exists_so_escape ?(skip_pos = -1) s = let buf = Buffer.create (String.length s + 1) in - Caml.StringLabels.iteri s ~f:(fun p c -> + Stdlib.StringLabels.iteri s ~f:(fun p c -> if p <> skip_pos && is_separator_unescaped s p c then Buffer.add_char buf escape_char; Buffer.add_char buf c); @@ -555,7 +555,7 @@ end = struct let register ?(desc = "no description provided") ?package ?(reliability = trustworthy) name = let name = Name.create ?package name in - let agent = Caml.Digest.string (Name.show name) in + let agent = Stdlib.Digest.string (Name.show name) in if Hashtbl.mem agents agent then failwithf "An agent with name `%a' already exists, please choose another name" @@ -2577,7 +2577,7 @@ module Knowledge = struct slot : Name.t; repr : string; error : Conflict.t; - trace : Caml.Printexc.raw_backtrace; + trace : Stdlib.Printexc.raw_backtrace; } let () = @@ -2587,7 +2587,7 @@ module Knowledge = struct @@ Format.asprintf "Unable to update the slot %a of %s,\n%a\nBacktrace:\n%s" Name.pp slot repr Conflict.pp error - (Caml.Printexc.raw_backtrace_to_string trace) + (Stdlib.Printexc.raw_backtrace_to_string trace) | _ -> None) let non_monotonic slot obj error trace = @@ -2626,7 +2626,7 @@ module Knowledge = struct }; } with Record.Merge_conflict err -> - non_monotonic slot obj err @@ Caml.Printexc.get_raw_backtrace ()) + non_monotonic slot obj err @@ Stdlib.Printexc.get_raw_backtrace ()) let notify { Slot.watchers } obj data = Hashtbl.data watchers @@ -2698,7 +2698,7 @@ module Knowledge = struct fun slot obj -> objects slot.cls >>| fun { vals } -> match Oid.Tree.find_exn vals obj with - | exception Caml.Not_found -> Sleep + | exception Stdlib.Not_found -> Sleep | { data; comp = slots } -> ( match Map.find slots (uid slot) with | Some (Work _) -> Awoke @@ -2771,7 +2771,7 @@ module Knowledge = struct fun slot id -> objects slot.cls >>| fun { Env.vals } -> match Oid.Tree.find_exn vals id with - | exception Caml.Not_found -> slot.dom.empty + | exception Stdlib.Not_found -> slot.dom.empty | { data } -> Record.get slot.key slot.dom data let rec collect_inner : ('a, 'p) slot -> 'a obj -> _ -> _ = @@ -3030,7 +3030,7 @@ module Knowledge = struct compute_value cls obj >>= fun () -> objects cls >>| fun { Env.vals } -> match Oid.Tree.find_exn vals obj with - | exception Caml.Not_found -> Value.empty cls + | exception Stdlib.Not_found -> Value.empty cls | { data = x } -> Value.create cls x let run cls obj s = diff --git a/bench/drivers/ppx_sexp_conv/inputs/bap_knowledge.ml b/bench/drivers/ppx_sexp_conv/inputs/bap_knowledge.ml index c3621dd8c..ba7e05881 100644 --- a/bench/drivers/ppx_sexp_conv/inputs/bap_knowledge.ml +++ b/bench/drivers/ppx_sexp_conv/inputs/bap_knowledge.ml @@ -24,9 +24,9 @@ type conflict = exn = .. module Conflict = struct type t = conflict = .. - let to_string = Caml.Printexc.to_string + let to_string = Stdlib.Printexc.to_string let pp ppf err = Format.fprintf ppf "%s" (to_string err) - let register_printer = Caml.Printexc.register_printer + let register_printer = Stdlib.Printexc.register_printer let sexp_of_t err = Sexp.Atom (to_string err) end @@ -153,22 +153,22 @@ end = struct let rec find_exn t k = match t with - | Nil -> raise Caml.Not_found + | Nil -> raise Stdlib.Not_found | Tip (k', v) when k = k' -> v - | Tip _ -> raise Caml.Not_found + | Tip _ -> raise Stdlib.Not_found | Bin (k', l, r) -> ( match Key.compare k' k with - | NA -> raise Caml.Not_found + | NA -> raise Stdlib.Not_found | LB -> find_exn l k | RB -> find_exn r k) - let find t k = try Some (find_exn t k) with Caml.Not_found -> None + let find t k = try Some (find_exn t k) with Stdlib.Not_found -> None let mem k t = try ignore (find_exn k t); true - with Caml.Not_found -> false + with Stdlib.Not_found -> false let node payload branching l r = match (l, r) with @@ -359,7 +359,7 @@ end = struct let unescaped_exists_so_escape ?(skip_pos = -1) s = let buf = Buffer.create (String.length s + 1) in - Caml.StringLabels.iteri s ~f:(fun p c -> + Stdlib.StringLabels.iteri s ~f:(fun p c -> if p <> skip_pos && is_separator_unescaped s p c then Buffer.add_char buf escape_char; Buffer.add_char buf c); @@ -555,7 +555,7 @@ end = struct let register ?(desc = "no description provided") ?package ?(reliability = trustworthy) name = let name = Name.create ?package name in - let agent = Caml.Digest.string (Name.show name) in + let agent = Stdlib.Digest.string (Name.show name) in if Hashtbl.mem agents agent then failwithf "An agent with name `%a' already exists, please choose another name" @@ -2577,7 +2577,7 @@ module Knowledge = struct slot : Name.t; repr : string; error : Conflict.t; - trace : Caml.Printexc.raw_backtrace; + trace : Stdlib.Printexc.raw_backtrace; } let () = @@ -2587,7 +2587,7 @@ module Knowledge = struct @@ Format.asprintf "Unable to update the slot %a of %s,\n%a\nBacktrace:\n%s" Name.pp slot repr Conflict.pp error - (Caml.Printexc.raw_backtrace_to_string trace) + (Stdlib.Printexc.raw_backtrace_to_string trace) | _ -> None) let non_monotonic slot obj error trace = @@ -2626,7 +2626,7 @@ module Knowledge = struct }; } with Record.Merge_conflict err -> - non_monotonic slot obj err @@ Caml.Printexc.get_raw_backtrace ()) + non_monotonic slot obj err @@ Stdlib.Printexc.get_raw_backtrace ()) let notify { Slot.watchers } obj data = Hashtbl.data watchers @@ -2698,7 +2698,7 @@ module Knowledge = struct fun slot obj -> objects slot.cls >>| fun { vals } -> match Oid.Tree.find_exn vals obj with - | exception Caml.Not_found -> Sleep + | exception Stdlib.Not_found -> Sleep | { data; comp = slots } -> ( match Map.find slots (uid slot) with | Some (Work _) -> Awoke @@ -2771,7 +2771,7 @@ module Knowledge = struct fun slot id -> objects slot.cls >>| fun { Env.vals } -> match Oid.Tree.find_exn vals id with - | exception Caml.Not_found -> slot.dom.empty + | exception Stdlib.Not_found -> slot.dom.empty | { data } -> Record.get slot.key slot.dom data let rec collect_inner : ('a, 'p) slot -> 'a obj -> _ -> _ = @@ -3030,7 +3030,7 @@ module Knowledge = struct compute_value cls obj >>= fun () -> objects cls >>| fun { Env.vals } -> match Oid.Tree.find_exn vals obj with - | exception Caml.Not_found -> Value.empty cls + | exception Stdlib.Not_found -> Value.empty cls | { data = x } -> Value.create cls x let run cls obj s = diff --git a/examples/simple-extension-rewriter/README.md b/examples/simple-extension-rewriter/README.md index 69eba73de..2f0c087bf 100644 --- a/examples/simple-extension-rewriter/README.md +++ b/examples/simple-extension-rewriter/README.md @@ -7,7 +7,7 @@ as a string. E.g., assuming we set `MY_VAR="foo"`, it will turn: ```ocaml -let () = print_string [%get_env "foo"] +let () = print_string [%get_env "MY_VAR"] ``` into: diff --git a/metaquot/dune b/metaquot/dune index a85cfb2db..dc1169ce6 100644 --- a/metaquot/dune +++ b/metaquot/dune @@ -4,5 +4,5 @@ (kind ppx_rewriter) (flags (:standard -safe-string)) - (libraries ppxlib ppxlib_traverse_builtins ppxlib_metaquot_lifters) + (libraries astlib ppxlib ppxlib_traverse_builtins ppxlib_metaquot_lifters) (ppx_runtime_libraries ppxlib_ast)) diff --git a/metaquot/ppxlib_metaquot.ml b/metaquot/ppxlib_metaquot.ml index dac00dd60..1de3eeff4 100644 --- a/metaquot/ppxlib_metaquot.ml +++ b/metaquot/ppxlib_metaquot.ml @@ -3,11 +3,33 @@ open Ast_builder.Default module E = Extension module A = Ast_pattern +type quoted_attributes = { + quoted_attributes : attributes; + (* The attributes that appear quoted, e.g. [@foo] in [%expr [%e e] [@foo]] *) + field_name : string; + (* The field name where attributes are stored for the kind of AST the quoted + attributes are placed on, e.g. pexp_attributes. *) +} + module Make (M : sig type result val annotate : result -> core_type -> result - val cast : extension -> result + + val cast : + (* The instance of the [std_lifters] class being used. *) + < attributes : attributes -> result + ; typed : result -> string -> result + ; .. > -> + extension -> + quoted_attributes option -> + (* e.g. [expression]; the callee is responsible for calling + [self#typed ast type_name] on the AST to add a type annotation + that constrains its type. + *) + type_name:string -> + result + val location : location -> result val location_stack : (location -> result) option val attributes : (location -> result) option @@ -48,45 +70,75 @@ struct method! expression e = match e.pexp_desc with | Pexp_extension (({ txt = "e"; _ }, _) as ext) -> - self#typed (M.cast ext) "expression" + let attributes = + { + quoted_attributes = e.pexp_attributes; + field_name = "pexp_attributes"; + } + in + M.cast self ext (Some attributes) ~type_name:"expression" | _ -> super#expression e method! pattern p = match p.ppat_desc with | Ppat_extension (({ txt = "p"; _ }, _) as ext) -> - self#typed (M.cast ext) "pattern" + let attributes = + { + quoted_attributes = p.ppat_attributes; + field_name = "ppat_attributes"; + } + in + M.cast self ext (Some attributes) ~type_name:"pattern" | _ -> super#pattern p method! core_type t = match t.ptyp_desc with | Ptyp_extension (({ txt = "t"; _ }, _) as ext) -> - self#typed (M.cast ext) "core_type" + let attributes = + { + quoted_attributes = t.ptyp_attributes; + field_name = "ptyp_attributes"; + } + in + M.cast self ext (Some attributes) ~type_name:"core_type" | _ -> super#core_type t method! module_expr m = match m.pmod_desc with | Pmod_extension (({ txt = "m"; _ }, _) as ext) -> - self#typed (M.cast ext) "module_expr" + let attributes = + { + quoted_attributes = m.pmod_attributes; + field_name = "pmod_attributes"; + } + in + M.cast self ext (Some attributes) ~type_name:"module_expr" | _ -> super#module_expr m method! module_type m = match m.pmty_desc with | Pmty_extension (({ txt = "m"; _ }, _) as ext) -> - self#typed (M.cast ext) "module_type" + let attributes = + { + quoted_attributes = m.pmty_attributes; + field_name = "pmty_attributes"; + } + in + M.cast self ext (Some attributes) ~type_name:"module_type" | _ -> super#module_type m method! structure_item i = match i.pstr_desc with | Pstr_extension ((({ txt = "i"; _ }, _) as ext), attrs) -> assert_no_attributes attrs; - self#typed (M.cast ext) "structure_item" + M.cast self ext None ~type_name:"structure_item" | _ -> super#structure_item i method! signature_item i = match i.psig_desc with | Psig_extension ((({ txt = "i"; _ }, _) as ext), attrs) -> assert_no_attributes attrs; - self#typed (M.cast ext) "signature_item" + M.cast self ext None ~type_name:"signature_item" | _ -> super#signature_item i end end @@ -102,16 +154,69 @@ module Expr = Make (struct let annotate e core_type = pexp_constraint ~loc:core_type.ptyp_loc e core_type - let cast ext = + (* Append the quoted attributes to the attributes present on the + antiquoted construct. Take this as example: + + [%expr [%e e] [@attr]] + + Suppose e has pexp_attributes = [attr1]. Then the resulting attributes + are [ attr1; [@attr] ]. The decision to put outer attributes (here, + [@attr]) at the end of the list is consistent with other parts of ppxlib + that accumulate attributes. + *) + let add_quoted_attributes self e { quoted_attributes; field_name } ~type_name + ~loc = + match quoted_attributes with + | [] -> self#typed e type_name + | _ :: _ -> + let loc = { loc with loc_ghost = true } in + let var = gen_symbol ~prefix:"_ppx_metaquot_helper_var" () in + let var_expr = pexp_ident ~loc (Located.mk ~loc (Lident var)) in + let field_name = Located.mk ~loc (Lident field_name) in + let reified_attrs = self#attributes quoted_attributes in + (* append arg1 arg2 = [%expr Stdlib.List.append [%e arg1] [%e arg2]] *) + let append arg1 arg2 = + pexp_apply ~loc + (pexp_ident ~loc + (Located.mk ~loc + (Ldot (Ldot (Lident "Stdlib", "List"), "append")))) + [ (Nolabel, arg1); (Nolabel, arg2) ] + in + (* + Morally, + {[ + let var = ([%expr e] : [%type: type_name]) in + { var + with pexp_attributes = var.pexp_attributes @ [%e reified_attrs ] + } + ]} + *) + pexp_let Nonrecursive ~loc + [ + value_binding ~loc + ~pat:(ppat_var ~loc (Located.mk ~loc var)) + ~expr:(self#typed e type_name); + ] + (pexp_record ~loc + [ + ( field_name, + append (pexp_field ~loc var_expr field_name) reified_attrs ); + ] + (Some var_expr)) + + let cast self ext attrs ~type_name = match snd ext with - | PStr [ { pstr_desc = Pstr_eval (e, attrs); _ } ] -> - assert_no_attributes attrs; - e + | PStr [ { pstr_desc = Pstr_eval (e, inner_attrs); _ } ] -> ( + assert_no_attributes inner_attrs; + match attrs with + | None -> self#typed e type_name + | Some quoted_attrs -> + add_quoted_attributes self e quoted_attrs ~type_name + ~loc:(loc_of_extension ext)) | _ -> - Ast_builder.Default.( - pexp_extension ~loc:(loc_of_extension ext) - (Location.error_extensionf ~loc:(loc_of_extension ext) - "expression expected")) + pexp_extension ~loc:(loc_of_extension ext) + (Location.error_extensionf ~loc:(loc_of_extension ext) + "expression expected") end) module Patt = Make (struct @@ -128,9 +233,14 @@ module Patt = Make (struct let annotate p core_type = ppat_constraint ~loc:core_type.ptyp_loc p core_type - let cast ext = + let cast self ext attrs ~type_name = match snd ext with - | PPat (p, None) -> p + | PPat (p, None) -> + (match attrs with + | None -> () + | Some { quoted_attributes; field_name = _ } -> + assert_no_attributes quoted_attributes); + self#typed p type_name | PPat (_, Some e) -> Ast_builder.Default.( ppat_extension ~loc:e.pexp_loc diff --git a/src/attribute.ml b/src/attribute.ml index 07cfa808a..f13e07cda 100644 --- a/src/attribute.ml +++ b/src/attribute.ml @@ -297,7 +297,14 @@ let declare_with_attr_loc name context pattern k = declare_with_all_args name context pattern (fun ~attr_loc ~name_loc:_ -> k ~attr_loc) -module Attribute_table = Caml.Hashtbl.Make (struct +type 'a flag = ('a, unit) t + +let declare_flag name context = + let payload_pattern = Ast_pattern.(pstr nil) in + let continuation ~attr_loc:_ ~name_loc:_ = () in + declare_with_all_args name context payload_pattern continuation + +module Attribute_table = Stdlib.Hashtbl.Make (struct type t = string loc let hash : t -> int = Hashtbl.hash @@ -356,6 +363,16 @@ let get t ?mark_as_seen:do_mark_as_seen x = get_res t ?mark_as_seen:do_mark_as_seen x |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) +let has_flag_res t ?mark_as_seen x = + match get_res ?mark_as_seen t x with + | Ok (Some ()) -> Ok true + | Ok None -> Ok false + | Error _ as e -> e + +let has_flag t ?mark_as_seen x = + has_flag_res t ?mark_as_seen x + |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) + let consume_res t x = let open Result in let attrs = Context.get_attributes t.context x in diff --git a/src/attribute.mli b/src/attribute.mli index 12f8d487d..fad528f23 100644 --- a/src/attribute.mli +++ b/src/attribute.mli @@ -135,6 +135,13 @@ val declare_with_attr_loc : ('a, 'c) t (** Same as [declare] but the callback receives the location of the attribute. *) +type 'a flag = ('a, unit) t +(** Types for attributes without payload. *) + +val declare_flag : string -> 'a Context.t -> 'a flag +(** Same as {!declare}, but the payload is expected to be empty. It is supposed + to be used in conjunction with {!has_flag}. *) + val name : _ t -> string val context : ('a, _) t -> 'a Context.t @@ -150,6 +157,17 @@ val get : ('a, 'b) t -> ?mark_as_seen:bool (** default [true] *) -> 'a -> 'b option (** See {!get_res}. Raises a located error if the attribute is duplicated *) +val has_flag_res : + 'a flag -> + ?mark_as_seen:bool (** default [true] *) -> + 'a -> + (bool, Location.Error.t NonEmptyList.t) result +(** Answers whether the given flag is attached as an attribute. See {!get_res} + for the meaning of [mark_as_seen]. *) + +val has_flag : 'a flag -> ?mark_as_seen:bool (** default [true] *) -> 'a -> bool +(** See {!has_flag_res}. Raises a located error if the attribute is duplicated. *) + val consume_res : ('a, 'b) t -> 'a -> (('a * 'b) option, Location.Error.t NonEmptyList.t) result (** [consume_res t x] returns the value associated to attribute [t] on [x] if diff --git a/src/caller_id.ml b/src/caller_id.ml index 0c354eb86..14d566e9a 100644 --- a/src/caller_id.ml +++ b/src/caller_id.ml @@ -1,7 +1,7 @@ (** Small helper to find out who is the caller of a function *) open! Import -module Printexc = Caml.Printexc +module Printexc = Stdlib.Printexc type t = Printexc.location option diff --git a/src/code_matcher.ml b/src/code_matcher.ml index 5a36b3b4d..052d23877 100644 --- a/src/code_matcher.ml +++ b/src/code_matcher.ml @@ -1,7 +1,7 @@ (*$ open Ppxlib_cinaps_helpers $*) open! Import -module Format = Caml.Format -module Filename = Caml.Filename +module Format = Stdlib.Format +module Filename = Stdlib.Filename (* TODO: make the "deriving." depend on the matching attribute name. *) let end_marker_sig = @@ -72,7 +72,9 @@ struct let diff_asts ~generated ~round_trip = let with_temp_file f = - Exn.protectx (Filename.temp_file "ppxlib" "") ~finally:Caml.Sys.remove ~f + Exn.protectx + (Filename.temp_file "ppxlib" "") + ~finally:Stdlib.Sys.remove ~f in with_temp_file (fun fn1 -> with_temp_file (fun fn2 -> @@ -93,7 +95,7 @@ struct (Filename.quote out) in let ok = - Caml.Sys.command cmd = 1 + Stdlib.Sys.command cmd = 1 || let cmd = Printf.sprintf @@ -102,7 +104,7 @@ struct (Filename.quote fn1) (Filename.quote fn2) (Filename.quote out) in - Caml.Sys.command cmd = 1 + Stdlib.Sys.command cmd = 1 in if ok then In_channel.read_all out else ""))) diff --git a/src/code_path.ml b/src/code_path.ml index 8e75866f6..f76713b28 100644 --- a/src/code_path.ml +++ b/src/code_path.ml @@ -12,7 +12,7 @@ type t = { let top_level ~file_path = let main_module_name = - file_path |> Caml.Filename.basename |> Caml.Filename.remove_extension + file_path |> Stdlib.Filename.basename |> Stdlib.Filename.remove_extension |> String.capitalize_ascii in { diff --git a/src/common.ml b/src/common.ml index 45c57eab1..12f5e5274 100644 --- a/src/common.ml +++ b/src/common.ml @@ -1,7 +1,7 @@ open! Import open Ast_builder.Default -module Buffer = Caml.Buffer -module Format = Caml.Format +module Buffer = Stdlib.Buffer +module Format = Stdlib.Format let lident x = Longident.Lident x diff --git a/src/deriving.ml b/src/deriving.ml index e10a2d198..90e33fcab 100644 --- a/src/deriving.ml +++ b/src/deriving.ml @@ -10,7 +10,7 @@ let keep_w32_intf = ref false let () = let keep_w32_spec = - Caml.Arg.Symbol + Stdlib.Arg.Symbol ( [ "impl"; "intf"; "both" ], function | "impl" -> keep_w32_impl := true @@ -21,7 +21,7 @@ let () = | _ -> assert false ) in let conv_w32_spec = - Caml.Arg.Symbol + Stdlib.Arg.Symbol ( [ "code"; "attribute" ], function | "code" -> do_insert_unused_warning_attribute := false @@ -44,7 +44,7 @@ let keep_w60_intf = ref false let () = let keep_w60_spec = - Caml.Arg.Symbol + Stdlib.Arg.Symbol ( [ "impl"; "intf"; "both" ], function | "impl" -> keep_w60_impl := true diff --git a/src/driver.ml b/src/driver.ml index 01121e24e..84cb8b1eb 100644 --- a/src/driver.ml +++ b/src/driver.ml @@ -3,9 +3,9 @@ open Import open Utils open Common open With_errors -module Arg = Caml.Arg +module Arg = Stdlib.Arg -let exe_name = Caml.Filename.basename Caml.Sys.executable_name +let exe_name = Stdlib.Filename.basename Stdlib.Sys.executable_name let args = ref [] let add_arg key spec ~doc = args := (key, spec, doc) :: !args let loc_fname = ref None @@ -172,7 +172,7 @@ module Transform = struct ?impl ?intf ?lint_impl ?lint_intf ?preprocess_impl ?preprocess_intf ?instrument ?(aliases = []) name = let rules = List.map extensions ~f:Context_free.Rule.extension @ rules in - let caller_id = Caller_id.get ~skip:[ Caml.__FILE__ ] in + let caller_id = Caller_id.get ~skip:[ Stdlib.__FILE__ ] in (match List.filter !all ~f:(fun ct -> has_name ct name) with | [] -> () | ct :: _ -> @@ -449,8 +449,8 @@ let debug_dropped_attribute name ~old_dropped ~new_dropped = Printf.eprintf "The following attributes %s after applying %s:\n" what name; List.iter diff ~f:(fun { Location.txt; loc } -> - Caml.Format.eprintf "- %a: %s\n" Location.print loc txt); - Caml.Format.eprintf "@.") + Stdlib.Format.eprintf "- %a: %s\n" Location.print loc txt); + Stdlib.Format.eprintf "@.") in print_diff "disappeared" new_dropped old_dropped; print_diff "reappeared" old_dropped new_dropped @@ -827,7 +827,7 @@ let versioned_errorf input_version input_file_name = in Error (err, input_version)) -let remove_no_error fn = try Caml.Sys.remove fn with Sys_error _ -> () +let remove_no_error fn = try Stdlib.Sys.remove fn with Sys_error _ -> () let protectx x ~f ~finally = match f x with @@ -842,7 +842,7 @@ let with_preprocessed_file fn ~f = match !preprocessor with | None -> f fn | Some pp -> - protectx (Caml.Filename.temp_file "ocamlpp" "") ~finally:remove_no_error + protectx (Stdlib.Filename.temp_file "ocamlpp" "") ~finally:remove_no_error ~f:(fun tmpfile -> match System.run_preprocessor ~pp ~input:fn ~output:tmpfile with | Ok () -> f tmpfile @@ -1146,7 +1146,7 @@ let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode let mismatches_found = match !corrections with | [] -> - if Caml.Sys.file_exists corrected then Caml.Sys.remove corrected; + if Stdlib.Sys.file_exists corrected then Stdlib.Sys.remove corrected; false | corrections -> Reconcile.reconcile corrections @@ -1160,14 +1160,14 @@ let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode | Null -> () | Pretty_print -> with_output output ~binary:false ~f:(fun oc -> - let ppf = Caml.Format.formatter_of_out_channel oc in + let ppf = Stdlib.Format.formatter_of_out_channel oc in (match ast with | Intf ast -> Pprintast.signature ppf ast | Impl ast -> Pprintast.structure ppf ast); let null_ast = match ast with Intf [] | Impl [] -> true | _ -> false in - if not null_ast then Caml.Format.pp_print_newline ppf ()) + if not null_ast then Stdlib.Format.pp_print_newline ppf ()) | Dump_ast -> with_output output ~binary:true ~f:(fun oc -> Ast_io.write oc @@ -1175,12 +1175,12 @@ let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode ~add_ppx_context:true) | Dparsetree -> with_output output ~binary:false ~f:(fun oc -> - let ppf = Caml.Format.formatter_of_out_channel oc in + let ppf = Stdlib.Format.formatter_of_out_channel oc in let ast = add_cookies ast in (match ast with | Intf ast -> Sexp.pp_hum ppf (Ast_traverse.sexp_of#signature ast) | Impl ast -> Sexp.pp_hum ppf (Ast_traverse.sexp_of#structure ast)); - Caml.Format.pp_print_newline ppf ()) + Stdlib.Format.pp_print_newline ppf ()) | Reconcile mode -> Reconcile.reconcile !replacements ~contents:(Lazy.force input_contents) @@ -1192,7 +1192,7 @@ let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode then ( Ppxlib_print_diff.print () ~file1:fn ~file2:corrected ~use_color:!use_color ?diff_command:!diff_command; - Caml.exit 1) + Stdlib.exit 1) let output_mode = ref Pretty_print let output = ref None @@ -1246,7 +1246,7 @@ let parse_apply_list s = Transform.has_name ct name)) then raise - (Caml.Arg.Bad + (Stdlib.Arg.Bad (Printf.sprintf "code transformation '%s' does not exist" name))); names @@ -1445,14 +1445,14 @@ let standalone_main () = interpret_mask (); if !request_print_transformations then ( print_transformations (); - Caml.exit 0); + Stdlib.exit 0); if !request_print_passes then ( print_passes (); - Caml.exit 0); + Stdlib.exit 0); match !input with | None -> Printf.eprintf "%s: no input file given\n%!" exe_name; - Caml.exit 2 + Stdlib.exit 2 | Some fn -> let kind = match !kind with @@ -1464,7 +1464,7 @@ let standalone_main () = Printf.eprintf "%s: don't know what to do with '%s', use -impl or -intf.\n" exe_name fn; - Caml.exit 2) + Stdlib.exit 2) in let input_name, relocate = match !loc_fname with None -> (fn, false) | Some fn -> (fn, true) @@ -1495,10 +1495,10 @@ let parse_input passed_in_args ~valid_args ~incorrect_input_msg = with | Arg.Bad msg -> Printf.eprintf "%s" msg; - Caml.exit 2 + Stdlib.exit 2 | Arg.Help msg -> Printf.eprintf "%s" msg; - Caml.exit 0 + Stdlib.exit 0 let run_as_ppx_rewriter_main ~standalone_args ~usage input = let valid_args = get_args ~standalone_args () in @@ -1509,23 +1509,23 @@ let run_as_ppx_rewriter_main ~standalone_args ~usage input = parse_input prog_name_and_flags ~valid_args ~incorrect_input_msg:usage; interpret_mask (); rewrite_binary_ast_file input_fn output_fn; - Caml.exit 0 + Stdlib.exit 0 | [ help; _ ] when String.equal help "-help" || String.equal help "--help" -> parse_input input ~valid_args ~incorrect_input_msg:usage; assert false | _ -> Printf.eprintf "Usage: %s\n%!" usage; - Caml.exit 2 + Stdlib.exit 2 let standalone_run_as_ppx_rewriter () = - let n = Array.length Caml.Sys.argv in + let n = Array.length Stdlib.Sys.argv in let usage = Printf.sprintf "%s -as-ppx [extra_args] " exe_name in let argv = Array.make (n - 1) "" in - argv.(0) <- Caml.Sys.argv.(0); + argv.(0) <- Stdlib.Sys.argv.(0); for i = 1 to n - 2 do - argv.(i) <- Caml.Sys.argv.(i + 1) + argv.(i) <- Stdlib.Sys.argv.(i + 1) done; let standalone_args = List.map standalone_args ~f:(fun (arg, spec, _doc) -> @@ -1537,23 +1537,25 @@ let standalone () = Astlib.init_error_reporting_style_using_env_vars (); try if - Array.length Caml.Sys.argv >= 2 + Array.length Stdlib.Sys.argv >= 2 && - match Caml.Sys.argv.(1) with "-as-ppx" | "--as-ppx" -> true | _ -> false + match Stdlib.Sys.argv.(1) with + | "-as-ppx" | "--as-ppx" -> true + | _ -> false then standalone_run_as_ppx_rewriter () else standalone_main (); - Caml.exit 0 + Stdlib.exit 0 with exn -> - Location.report_exception Caml.Format.err_formatter exn; - Caml.exit 1 + Location.report_exception Stdlib.Format.err_formatter exn; + Stdlib.exit 1 let run_as_ppx_rewriter () = let usage = Printf.sprintf "%s [extra_args] " exe_name in - let input = Caml.Sys.argv in + let input = Stdlib.Sys.argv in try run_as_ppx_rewriter_main ~standalone_args:[] ~usage input with exn -> - Location.report_exception Caml.Format.err_formatter exn; - Caml.exit 1 + Location.report_exception Stdlib.Format.err_formatter exn; + Stdlib.exit 1 let pretty () = !pretty diff --git a/src/driver.mli b/src/driver.mli index cdc7061dc..41a759828 100644 --- a/src/driver.mli +++ b/src/driver.mli @@ -6,7 +6,7 @@ open Import -val add_arg : Caml.Arg.key -> Caml.Arg.spec -> doc:string -> unit +val add_arg : Stdlib.Arg.key -> Stdlib.Arg.spec -> doc:string -> unit (** Add one argument to the command line *) (** Error reported by linters *) diff --git a/src/location.ml b/src/location.ml index 8de4cedda..54daa6397 100644 --- a/src/location.ml +++ b/src/location.ml @@ -34,7 +34,7 @@ let of_lexbuf (lexbuf : Lexing.lexbuf) = } let print ppf t = - Caml.Format.fprintf ppf "File \"%s\", line %d, characters %d-%d:" + Stdlib.Format.fprintf ppf "File \"%s\", line %d, characters %d-%d:" t.loc_start.pos_fname t.loc_start.pos_lnum (t.loc_start.pos_cnum - t.loc_start.pos_bol) (t.loc_end.pos_cnum - t.loc_start.pos_bol) @@ -76,6 +76,6 @@ let error_extensionf ~loc fmt = exception Error = L.Error let () = - Caml.Printexc.register_printer (function + Stdlib.Printexc.register_printer (function | Error e -> Some (Error.message e) | _ -> None) diff --git a/src/location.mli b/src/location.mli index 642b9ab78..a6f4f6b54 100644 --- a/src/location.mli +++ b/src/location.mli @@ -27,7 +27,8 @@ val init : Lexing.lexbuf -> string -> unit (** Set the file name and line number of the [lexbuf] to be the start of the named file. *) -val raise_errorf : ?loc:t -> ('a, Caml.Format.formatter, unit, 'b) format4 -> 'a +val raise_errorf : + ?loc:t -> ('a, Stdlib.Format.formatter, unit, 'b) format4 -> 'a (** Raise a located error. Should be avoided as much as possible, in favor of {!error_extensionf}. See the {{!"good-practices".handling_errors} relevant} part of the tutorial. *) @@ -35,10 +36,10 @@ val raise_errorf : ?loc:t -> ('a, Caml.Format.formatter, unit, 'b) format4 -> 'a val of_lexbuf : Lexing.lexbuf -> t (** Return the location corresponding to the last matched regular expression *) -val report_exception : Caml.Format.formatter -> exn -> unit +val report_exception : Stdlib.Format.formatter -> exn -> unit (** Report an exception on the given formatter *) -val print : Caml.Format.formatter -> t -> unit +val print : Stdlib.Format.formatter -> t -> unit (** Prints [File "...", line ..., characters ...-...:] *) type nonrec 'a loc = 'a loc = { txt : 'a; loc : t } @@ -59,7 +60,7 @@ module Error : sig val make : loc:location -> string -> sub:(location * string) list -> t val createf : - loc:location -> ('a, Caml.Format.formatter, unit, t) format4 -> 'a + loc:location -> ('a, Stdlib.Format.formatter, unit, t) format4 -> 'a val message : t -> string val set_message : t -> string -> t diff --git a/src/name.ml b/src/name.ml index 413b7bee8..76d9d6284 100644 --- a/src/name.ml +++ b/src/name.ml @@ -1,5 +1,5 @@ open! Import -module Format = Caml.Format +module Format = Stdlib.Format let fold_dot_suffixes name ~init:acc ~f = let rec collapse_after_at = function @@ -44,10 +44,15 @@ module Pattern = struct let matches t matched = String.Set.mem matched t.dot_suffixes end -let get_outer_namespace name = +(* On the namespace "a.NAMESPACE", return the pair ("a", NAMESPACE) *) +let split_outer_namespace name = match String.index_opt name '.' with | None -> None - | Some i -> Some (String.sub name ~pos:0 ~len:i) + | Some i -> + let n = String.length name in + let before_dot = String.sub name ~pos:0 ~len:i in + let after_dot = String.sub name ~pos:(i + 1) ~len:(n - i - 1) in + Some (before_dot, after_dot) module Allowlisted = struct (* Allow list the following attributes, as well as all their dot suffixes. @@ -114,8 +119,45 @@ module Allowlisted = struct end module Reserved_namespaces = struct - let tbl : (string, unit) Hashtbl.t = Hashtbl.create 16 - let reserve ns = Hashtbl.add_exn tbl ~key:ns ~data:() + type reserved = (string, sub_namespaces) Hashtbl.t + and sub_namespaces = All | Sub_namespaces of reserved + + (* If [tbl] contains a mapping from "x" to [All], then "x" and all paths that + * start with "x." are reserved with respect to [tbl] + * + * If [tbl] contains a mapping from "x" to [Sub_namespaces tbl'], and P is + * reserved with respect to [tbl'], then all paths "x.P" are reserved with + * respect to [tbl]. + *) + let create_reserved () : reserved = Hashtbl.create 16 + + let rec reserve ns tbl = + match split_outer_namespace ns with + | None -> Hashtbl.add_exn tbl ~key:ns ~data:All + | Some (outer_ns, rest_ns) -> ( + match + Hashtbl.find_or_add tbl outer_ns ~default:(fun () -> + Sub_namespaces (create_reserved ())) + with + | Sub_namespaces rest_tbl -> reserve rest_ns rest_tbl + | All -> ()) + + let rec is_in_reserved_namespaces name tbl = + match split_outer_namespace name with + | Some (ns, rest) -> ( + match Hashtbl.find_opt tbl ns with + | Some (Sub_namespaces rest_tbl) -> + is_in_reserved_namespaces rest rest_tbl + | Some All -> true + | None -> false) + | None -> ( + match Hashtbl.find_opt tbl name with + | Some All -> true + | Some (Sub_namespaces _) | None -> false) + + let tbl = create_reserved () + let reserve ns = reserve ns tbl + let is_in_reserved_namespaces name = is_in_reserved_namespaces name tbl let () = reserve "merlin" let () = reserve "reason" let () = reserve "refmt" (* reason *) @@ -123,11 +165,7 @@ module Reserved_namespaces = struct let () = reserve "res" (* rescript *) let () = reserve "metaocaml" let () = reserve "ocamlformat" - - let is_in_reserved_namespaces name = - match get_outer_namespace name with - | Some ns -> Hashtbl.mem tbl ns - | None -> Hashtbl.mem tbl name + let () = reserve "ppxlib.migration" let check_not_reserved ~kind name = let kind, list = @@ -180,7 +218,7 @@ module Registrar = struct | Some e -> let declared_at = function | None -> "" - | Some (loc : Caml.Printexc.location) -> + | Some (loc : Stdlib.Printexc.location) -> Printf.sprintf " declared at %s:%d" loc.filename loc.line_number in let context = diff --git a/src/name.mli b/src/name.mli index d8b5c25aa..0ec02f8fd 100644 --- a/src/name.mli +++ b/src/name.mli @@ -109,7 +109,8 @@ module Reserved_namespaces : sig This is here to insure that the rewriter cohabits well with other rewriter or tools (e.g. merlin) which might leave attribute on the AST. - N.B. the "merlin" namespace is reserved by default. *) + N.B. the following namespaces are reserved by default: [merlin], [reason], + [refmt] [ns], [res], [metaocaml], [ocamlformat] and [ppxlib]. *) val is_in_reserved_namespaces : string -> bool end diff --git a/src/reconcile.ml b/src/reconcile.ml index eba810d63..b148d4d21 100644 --- a/src/reconcile.ml +++ b/src/reconcile.ml @@ -6,9 +6,9 @@ module Context = struct | Extension of 'a Extension.Context.t | Floating_attribute of 'a Attribute.Floating.Context.t - let paren pp ppf x = Caml.Format.fprintf ppf "(%a)" pp x + let paren pp ppf x = Stdlib.Format.fprintf ppf "(%a)" pp x - let printer : type a. a t -> Caml.Format.formatter -> a -> unit = + let printer : type a. a t -> Stdlib.Format.formatter -> a -> unit = let open Extension.Context in let open Attribute.Floating.Context in function @@ -51,13 +51,13 @@ module Replacement = struct let s = let printer = Context.printer context in match generated with - | Single x -> Caml.Format.asprintf "%a" printer x + | Single x -> Stdlib.Format.asprintf "%a" printer x | Many l -> - Caml.Format.asprintf "%a" + Stdlib.Format.asprintf "%a" (fun ppf l -> List.iter l ~f:(fun x -> printer ppf x; - Caml.Format.pp_print_newline ppf ())) + Stdlib.Format.pp_print_newline ppf ())) l in let is_ws = function ' ' | '\t' | '\r' -> true | _ -> false in @@ -169,24 +169,24 @@ let with_output ~styler ~(kind : Kind.t) fn ~f = | None -> with_output fn ~binary:false ~f | Some cmd -> let tmp_fn, oc = - Caml.Filename.open_temp_file "ppxlib_driver" + Stdlib.Filename.open_temp_file "ppxlib_driver" (match kind with Impl -> ".ml" | Intf -> ".mli") in let cmd = Printf.sprintf "%s %s%s" cmd - (Caml.Filename.quote tmp_fn) + (Stdlib.Filename.quote tmp_fn) (match fn with | None -> "" - | Some fn -> " > " ^ Caml.Filename.quote fn) + | Some fn -> " > " ^ Stdlib.Filename.quote fn) in let n = - Exn.protectx tmp_fn ~finally:Caml.Sys.remove ~f:(fun _ -> + Exn.protectx tmp_fn ~finally:Stdlib.Sys.remove ~f:(fun _ -> Exn.protectx oc ~finally:close_out ~f; - Caml.Sys.command cmd) + Stdlib.Sys.command cmd) in if n <> 0 then ( Printf.eprintf "command exited with code %d: %s\n" n cmd; - Caml.exit 1) + Stdlib.exit 1) let reconcile ?styler (repls : Replacements.t) ~kind ~contents ~input_filename ~output ~input_name ~target = diff --git a/src/utils.ml b/src/utils.ml index 5dedb6eb6..555e604ce 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -9,8 +9,8 @@ module Kind = struct type t = Intf | Impl let of_filename fn : t option = - if Caml.Filename.check_suffix fn ".ml" then Some Impl - else if Caml.Filename.check_suffix fn ".mli" then Some Intf + if Stdlib.Filename.check_suffix fn ".ml" then Some Impl + else if Stdlib.Filename.check_suffix fn ".mli" then Some Intf else None let describe = function Impl -> "implementation" | Intf -> "interface" @@ -213,9 +213,9 @@ module System = struct let run_preprocessor ~pp ~input ~output = let command = Printf.sprintf "%s %s > %s" pp - (if String.equal input "-" then "" else Caml.Filename.quote input) - (Caml.Filename.quote output) + (if String.equal input "-" then "" else Stdlib.Filename.quote input) + (Stdlib.Filename.quote output) in - if Caml.Sys.command command = 0 then Ok () + if Stdlib.Sys.command command = 0 then Ok () else Error (command, Ast_io.fall_back_input_version) end diff --git a/stdppx/stdppx.ml b/stdppx/stdppx.ml index b3a81e77d..2bcc4b8e0 100644 --- a/stdppx/stdppx.ml +++ b/stdppx/stdppx.ml @@ -1,5 +1,5 @@ -module Caml = Stdlib -open Caml +module Caml = Stdlib [@@deprecated "[since 2023-06] use Stdlib instead"] +open Stdlib open StdLabels module Sexp = Sexplib0.Sexp module Sexpable = Sexplib0.Sexpable diff --git a/test/501_migrations/normal_migrations.t b/test/501_migrations/normal_migrations.t index c9d2c8d42..8e0de5f89 100644 --- a/test/501_migrations/normal_migrations.t +++ b/test/501_migrations/normal_migrations.t @@ -3,95 +3,111 @@ The 501 parsetree contains a parsing modificacion. AST's resulting from 1. parsing on 5.1.0 directly 2. parsing on 5.1.0, migrating down to 5.0.0 and migrating back to 5.1.0 -We only expect a diff in one special case. + +------------------ + +Tests for the Parsetree change for type constraints in value bindings $ echo "let x : int = 5" > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] $ echo "let (x) : int = 5" > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] $ echo "let _ : int = 5" > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] $ echo "let f : type a b c. a -> b -> c = fun x y -> assert false" > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] $ echo "let f = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] $ echo "let _ = (fun (type a) (type b) (type c) -> (fun x y -> assert false : a -> b -> c))" > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] $ echo "let f : type a . a -> a = fun x -> x" > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] $ echo "let (x, y) : (int * int) = assert false" > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] $ echo "let f : type a . a = assert false" > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] $ echo 'let x : [`A] :> [`A | `B] = `A' > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] $ echo 'let x : [`A | `B] = (`A : [`A] :> [`A | `B])' > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] $ echo 'let x : :> = object method m = 0 method n = 1 end' > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] $ echo 'let x :> = object method m = 0 method n = 1 end' > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] Here might be a problem in the upward migration: the 5.1.0 parser parses the constraint as a pattern constraint. However, the upward migration makes a value binding constraint out of it. $ echo "let ((x,y) : (int*int)) = (assert false: int * int)" > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe - 6,25c6,23 - < pattern (file.ml[1,0+4]..[1,0+23]) - < Ppat_constraint - < pattern (file.ml[1,0+5]..[1,0+10]) - < Ppat_tuple - < [ - < pattern (file.ml[1,0+6]..[1,0+7]) - < Ppat_var "x" (file.ml[1,0+6]..[1,0+7]) - < pattern (file.ml[1,0+8]..[1,0+9]) - < Ppat_var "y" (file.ml[1,0+8]..[1,0+9]) - < ] - < core_type (file.ml[1,0+14]..[1,0+21]) - < Ptyp_tuple - < [ - < core_type (file.ml[1,0+14]..[1,0+17]) - < Ptyp_constr "int" (file.ml[1,0+14]..[1,0+17]) - < [] - < core_type (file.ml[1,0+18]..[1,0+21]) - < Ptyp_constr "int" (file.ml[1,0+18]..[1,0+21]) - < [] - < ] - --- - > pattern (file.ml[1,0+5]..[1,0+10]) - > Ppat_tuple - > [ - > pattern (file.ml[1,0+6]..[1,0+7]) - > Ppat_var "x" (file.ml[1,0+6]..[1,0+7]) - > pattern (file.ml[1,0+8]..[1,0+9]) - > Ppat_var "y" (file.ml[1,0+8]..[1,0+9]) - > ] - > core_type (file.ml[1,0+14]..[1,0+21]) - > Ptyp_tuple - > [ - > core_type (file.ml[1,0+14]..[1,0+17]) - > Ptyp_constr "int" (file.ml[1,0+14]..[1,0+17]) - > [] - > core_type (file.ml[1,0+18]..[1,0+21]) - > Ptyp_constr "int" (file.ml[1,0+18]..[1,0+21]) - > [] - > ] + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + @@ -6,20 +6,18 @@ + - pattern (file.ml[1,0+4]..[1,0+23]) + - Ppat_constraint + - pattern (file.ml[1,0+5]..[1,0+10]) + - Ppat_tuple + - [ + - pattern (file.ml[1,0+6]..[1,0+7]) + - Ppat_var "x" (file.ml[1,0+6]..[1,0+7]) + - pattern (file.ml[1,0+8]..[1,0+9]) + - Ppat_var "y" (file.ml[1,0+8]..[1,0+9]) + - ] + - core_type (file.ml[1,0+14]..[1,0+21]) + - Ptyp_tuple + - [ + - core_type (file.ml[1,0+14]..[1,0+17]) + - Ptyp_constr "int" (file.ml[1,0+14]..[1,0+17]) + - [] + - core_type (file.ml[1,0+18]..[1,0+21]) + - Ptyp_constr "int" (file.ml[1,0+18]..[1,0+21]) + - [] + - ] + + pattern (file.ml[1,0+5]..[1,0+10]) + + Ppat_tuple + + [ + + pattern (file.ml[1,0+6]..[1,0+7]) + + Ppat_var "x" (file.ml[1,0+6]..[1,0+7]) + + pattern (file.ml[1,0+8]..[1,0+9]) + + Ppat_var "y" (file.ml[1,0+8]..[1,0+9]) + + ] + + core_type (file.ml[1,0+14]..[1,0+21]) + + Ptyp_tuple + + [ + + core_type (file.ml[1,0+14]..[1,0+17]) + + Ptyp_constr "int" (file.ml[1,0+14]..[1,0+17]) + + [] + + core_type (file.ml[1,0+18]..[1,0+21]) + + Ptyp_constr "int" (file.ml[1,0+18]..[1,0+21]) + + [] + + ] $ echo "let f: type a. a option -> _ = assert false" > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] Here we may expect a diff (downwards migrating should yield the same as in the example right above). @@ -100,11 +116,13 @@ However, those case are recoverable. First, both $ echo "let f : 'a . 'a = (fun (type a) -> (assert false : a))" > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] and $ echo "let f : type a . a = assert false" > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] are translated to the same 5.0 AST tree. But the locations on the expression constraint and pattern constraint are only the same in the second case. @@ -113,12 +131,14 @@ Thus, we can distinguish between the two. Similarly, the syntactic translation for $ echo 'let x :> [`A | `B] = `A' > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] and $ echo 'let x : [`A | `B] = (`A :> [ `A | `B ] )' > file.ml - $ ./compare_on.exe file.ml ./identity_driver.exe + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] are pretty close: The former is translated to "let (x: ø . [`A | `B]) = (`A :> [`A | `B])" whereas the latter is mapped to "let (x: ø . [`A | `B]) = ((`A :> [`A | `B]): [`A | `B]) ". @@ -129,3 +149,36 @@ Let's make sure that in the examples with diffs, the location invariants are still fulfilled. $ echo "let ((x,y) : (int*int)) = (assert false: int * int)" > file.ml $ ./identity_driver.exe -check -locations-check file.ml > /dev/null + +------------------ + +Tests for the Parsetree change for generative functor applications + + + $ cat > file.ml << EOF + > module F () = struct end + > module M = F () + > EOF + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ cat > file.ml << EOF + > module F () = struct end + > module M = F [@attr1] () [@attr2] + > EOF + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ cat > file.ml << EOF + > module F () = struct end + > module M = F(struct end) + > EOF + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + + $ cat > file.ml << EOF + > module F (N : sig end) = struct end + > module M = F (struct end) + > EOF + $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] diff --git a/test/501_migrations/one_migration.t b/test/501_migrations/one_migration.t index 70a549b1f..48e844466 100644 --- a/test/501_migrations/one_migration.t +++ b/test/501_migrations/one_migration.t @@ -570,3 +570,561 @@ So let's only keep one example. ((loc_start ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) (loc_end ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 15))) (loc_ghost false))))) + + $ cat > file.ml << EOF + > module F () = struct end + > module M = F () + > EOF + $ ./identity_driver.exe -dparsetree file.ml + (((pstr_desc + (Pstr_attribute + ((attr_name + ((txt ocaml.ppx.context) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) + (loc_ghost true))))) + (attr_payload + (PStr + (((pstr_desc + (Pstr_eval + ((pexp_desc + (Pexp_record + ((((txt (Lident tool_name)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_constant + (Pconst_string ppxlib_driver + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)) + ()))) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ()))) + (((txt (Lident include_dirs)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_construct + ((txt (Lident [])) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ()))) + (((txt (Lident load_path)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_construct + ((txt (Lident [])) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ()))) + (((txt (Lident open_modules)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_construct + ((txt (Lident [])) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ()))) + (((txt (Lident for_package)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_construct + ((txt (Lident None)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ()))) + (((txt (Lident debug)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_construct + ((txt (Lident false)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ()))) + (((txt (Lident use_threads)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_construct + ((txt (Lident false)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ()))) + (((txt (Lident use_vmthreads)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_construct + ((txt (Lident false)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ()))) + (((txt (Lident recursive_types)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_construct + ((txt (Lident false)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ()))) + (((txt (Lident principal)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_construct + ((txt (Lident false)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ()))) + (((txt (Lident transparent_modules)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_construct + ((txt (Lident false)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ()))) + (((txt (Lident unboxed_types)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_construct + ((txt (Lident false)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ()))) + (((txt (Lident unsafe_string)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_construct + ((txt (Lident false)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ()))) + (((txt (Lident cookies)) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ((pexp_desc + (Pexp_construct + ((txt (Lident [])) + (loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true)))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) + (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ())))) + ())) + (pexp_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) + (loc_ghost true))) + (pexp_loc_stack ()) (pexp_attributes ())) + ())) + (pstr_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) + (loc_end + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) + (loc_ghost true))))))) + (attr_loc + ((loc_start + ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) + (loc_end ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) + (loc_ghost true)))))) + (pstr_loc + ((loc_start ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) + (loc_end ((pos_fname _none_) (pos_lnum 0) (pos_bol 0) (pos_cnum -1))) + (loc_ghost true)))) + ((pstr_desc + (Pstr_module + ((pmb_name + ((txt (F)) + (loc + ((loc_start + ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 7))) + (loc_end + ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 8))) + (loc_ghost false))))) + (pmb_expr + ((pmod_desc + (Pmod_functor Unit + ((pmod_desc (Pmod_structure ())) + (pmod_loc + ((loc_start + ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 14))) + (loc_end + ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 24))) + (loc_ghost false))) + (pmod_attributes ())))) + (pmod_loc + ((loc_start + ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 9))) + (loc_end + ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 24))) + (loc_ghost false))) + (pmod_attributes ()))) + (pmb_attributes ()) + (pmb_loc + ((loc_start + ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) + (loc_end ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 24))) + (loc_ghost false)))))) + (pstr_loc + ((loc_start ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 0))) + (loc_end ((pos_fname file.ml) (pos_lnum 1) (pos_bol 0) (pos_cnum 24))) + (loc_ghost false)))) + ((pstr_desc + (Pstr_module + ((pmb_name + ((txt (M)) + (loc + ((loc_start + ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 32))) + (loc_end + ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 33))) + (loc_ghost false))))) + (pmb_expr + ((pmod_desc + (Pmod_apply + ((pmod_desc + (Pmod_ident + ((txt (Lident F)) + (loc + ((loc_start + ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 36))) + (loc_end + ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 37))) + (loc_ghost false)))))) + (pmod_loc + ((loc_start + ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 36))) + (loc_end + ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 37))) + (loc_ghost false))) + (pmod_attributes ())) + ((pmod_desc (Pmod_structure ())) + (pmod_loc + ((loc_start + ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 36))) + (loc_end + ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 40))) + (loc_ghost false))) + (pmod_attributes ())))) + (pmod_loc + ((loc_start + ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 36))) + (loc_end + ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 40))) + (loc_ghost false))) + (pmod_attributes ()))) + (pmb_attributes ()) + (pmb_loc + ((loc_start + ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 25))) + (loc_end + ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 40))) + (loc_ghost false)))))) + (pstr_loc + ((loc_start ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 25))) + (loc_end ((pos_fname file.ml) (pos_lnum 2) (pos_bol 25) (pos_cnum 40))) + (loc_ghost false))))) diff --git a/test/501_migrations/reverse_migrations.t b/test/501_migrations/reverse_migrations.t index 9120ed91e..81bee9734 100644 --- a/test/501_migrations/reverse_migrations.t +++ b/test/501_migrations/reverse_migrations.t @@ -4,6 +4,10 @@ AST's resulting from 1. parsing on 5.0.0 directly 2. parsing on 5.0.0, migrating up to 5.1.0 and migrating back to 5.0.0 +------------------ + +Tests for the Parsetree change for type constraints in value bindings + $ echo "let x : int = 5" > file.ml $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" [1] @@ -162,3 +166,36 @@ the location invariants are still fulfilled. $ echo "let (x) : int = 5" > file.ml $ ./reverse_migrations.exe -check -locations-check file.ml > /dev/null + + +------------------ + +Tests for the Parsetree change for generative functor applications + + $ cat > file.ml << EOF + > module F () = struct end + > module M = F () + > EOF + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + [1] + +When going up, F(struct end) is turned into F(), which makes the location be lost. +It could be stored in an attribute, or turned into F(struct end [@warning "-73"]). + + $ cat > file.ml << EOF + > module F () = struct end + > module M = F(struct end) + > EOF + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + @@ -17 +17 @@ + - module_expr (file.ml[2,25+13]..[2,25+23]) + + module_expr (file.ml[2,25+11]..[2,25+24]) + + $ cat > file.ml << EOF + > module F (N : sig end) = struct end + > module M = F (struct end) + > EOF + $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations" + @@ -20 +20 @@ + - module_expr (file.ml[2,36+14]..[2,36+24]) + + module_expr (file.ml[2,36+11]..[2,36+25]) diff --git a/test/code_path/dune b/test/code_path/dune index b88be2aec..06179b3fc 100644 --- a/test/code_path/dune +++ b/test/code_path/dune @@ -1,9 +1,7 @@ (rule (alias runtest) (enabled_if - (and - (>= %{ocaml_version} "4.10.0") - (< %{ocaml_version} "5.1.0"))) + (>= %{ocaml_version} "4.10.0")) (deps (:test test.ml) (package ppxlib)) @@ -13,21 +11,3 @@ (progn (run expect-test %{test}) (diff? %{test} %{test}.corrected))))) - -(rule - (alias runtest) - (enabled_if - (>= %{ocaml_version} "5.1.0")) - (deps - (:test test.ml) - (:t test_510.ml) - (package ppxlib)) - (action - (chdir - %{project_root} - (progn - (run mv %{t} %{t}.old) - (run cp %{test} %{t}) - (run expect-test %{t}) - (run mv %{t}.old %{t}) - (diff? %{t} %{t}.corrected))))) diff --git a/test/code_path/test_510.ml b/test/code_path/test_510.ml deleted file mode 100644 index 976aac8ef..000000000 --- a/test/code_path/test_510.ml +++ /dev/null @@ -1,152 +0,0 @@ -open Ppxlib - -let sexp_of_code_path code_path = - Sexplib0.Sexp.message - "code_path" - [ "main_module_name", Sexplib0.Sexp_conv.sexp_of_string (Code_path.main_module_name code_path) - ; "submodule_path", Sexplib0.Sexp_conv.sexp_of_list Sexplib0.Sexp_conv.sexp_of_string (Code_path.submodule_path code_path) - ; "enclosing_module", Sexplib0.Sexp_conv.sexp_of_string (Code_path.enclosing_module code_path) - ; "enclosing_value", Sexplib0.Sexp_conv.sexp_of_option Sexplib0.Sexp_conv.sexp_of_string (Code_path.enclosing_value code_path) - ; "value", Sexplib0.Sexp_conv.sexp_of_option Sexplib0.Sexp_conv.sexp_of_string (Code_path.value code_path) - ; "fully_qualified_path", Sexplib0.Sexp_conv.sexp_of_string (Code_path.fully_qualified_path code_path) - ] - -let () = - Driver.register_transformation "test" - ~extensions:[ - Extension.V3.declare "code_path" - Expression - Ast_pattern.(pstr nil) - (fun ~ctxt -> - let loc = Expansion_context.Extension.extension_point_loc ctxt in - let code_path = Expansion_context.Extension.code_path ctxt in - Ast_builder.Default.estring ~loc - (Sexplib0.Sexp.to_string (sexp_of_code_path code_path))) - ] -[%%expect{| -val sexp_of_code_path : Code_path.t -> Sexplib0.Sexp.t = -|}] - -let s = - let module A = struct - module A' = struct - let a = - let module B = struct - module B' = struct - let b = - let module C = struct - module C' = struct - let c = [%code_path] - end - end - in C.C'.c - end - end - in B.B'.b - end - end - in A.A'.a -;; -[%%expect{| -val s : string = - "(code_path(main_module_name Test_510)(submodule_path())(enclosing_module C')(enclosing_value(c))(value(s))(fully_qualified_path Test_510.s))" -|}] - -let module M = struct - let m = [%code_path] - end - in - M.m -[%%expect{| -- : string = -"(code_path(main_module_name Test_510)(submodule_path())(enclosing_module M)(enclosing_value(m))(value())(fully_qualified_path Test_510))" -|}] - -module Outer = struct - module Inner = struct - let code_path = [%code_path] - end -end -let _ = Outer.Inner.code_path -[%%expect{| -module Outer : sig module Inner : sig val code_path : string end end -- : string = -"(code_path(main_module_name Test_510)(submodule_path(Outer Inner))(enclosing_module Inner)(enclosing_value(code_path))(value(code_path))(fully_qualified_path Test_510.Outer.Inner.code_path))" -|}] - -module Functor() = struct - let code_path = ref "" - module _ = struct - let x = - let module First_class = struct - code_path := [%code_path] - end in - let module _ = First_class in - () - ;; - - ignore x - end -end -let _ = let module M = Functor() in !M.code_path -[%%expect{| -module Functor : functor () -> sig val code_path : string ref end -Line _: -Error (warning 73 [generative-application-expects-unit]): A generative functor -should be applied to '()'; using '(struct end)' is deprecated. -|}] - -module Actual = struct - let code_path = [%code_path] -end [@enter_module Dummy] -let _ = Actual.code_path -[%%expect{| - -module Actual : sig val code_path : string end - -- : string = -"(code_path(main_module_name Test_510)(submodule_path(Actual Dummy))(enclosing_module Dummy)(enclosing_value(code_path))(value(code_path))(fully_qualified_path Test_510.Actual.Dummy.code_path))" -|}] - -module Ignore_me = struct - let code_path = [%code_path] -end [@@do_not_enter_module] -let _ = Ignore_me.code_path -[%%expect{| - -module Ignore_me : sig val code_path : string end - -- : string = -"(code_path(main_module_name Test_510)(submodule_path())(enclosing_module Test_510)(enclosing_value(code_path))(value(code_path))(fully_qualified_path Test_510.code_path))" -|}] - -let _ = - (let module Ignore_me = struct - let code_path = [%code_path] - end - in - Ignore_me.code_path) - [@do_not_enter_module] -[%%expect{| - -- : string = -"(code_path(main_module_name Test_510)(submodule_path())(enclosing_module Test_510)(enclosing_value(code_path))(value())(fully_qualified_path Test_510))" -|}] - -let _ = ([%code_path] [@ppxlib.enter_value dummy]) -[%%expect{| - -- : string = -"(code_path(main_module_name Test_510)(submodule_path())(enclosing_module Test_510)(enclosing_value(dummy))(value(dummy))(fully_qualified_path Test_510.dummy))" -|}] - -let _ = - let ignore_me = [%code_path] - [@@do_not_enter_value] - in - ignore_me -[%%expect{| - -- : string = -"(code_path(main_module_name Test_510)(submodule_path())(enclosing_module Test_510)(enclosing_value())(value())(fully_qualified_path Test_510))" -|}] diff --git a/test/driver/attributes/test.ml b/test/driver/attributes/test.ml index 51b983a96..6e5f1bb7d 100644 --- a/test/driver/attributes/test.ml +++ b/test/driver/attributes/test.ml @@ -92,3 +92,113 @@ type t2 = < > Line _, characters 17-20: Error: Attribute `foo' was not used |}] + +(* Reserved Namespaces *) + +(* ppxlib checks that unreserved attributes aren't dropped *) + +let x = (42 [@bar]) +[%%expect{| +Line _, characters 14-17: +Error: Attribute `bar' was silently dropped +|}] + +let x = (42 [@bar.baz]) +[%%expect{| +Line _, characters 14-21: +Error: Attribute `bar.baz' was silently dropped +|}] + +(* But reserving a namespace disables those checks. *) + +let () = Reserved_namespaces.reserve "bar" + +let x = (42 [@bar]) +let x = (42 [@bar.baz]) +[%%expect{| +val x : int = 42 +val x : int = 42 +|}] + +let x = (42 [@bar_not_proper_sub_namespace]) +[%%expect{| +Line _, characters 14-42: +Error: Attribute `bar_not_proper_sub_namespace' was silently dropped +|}] + +(* The namespace reservation process understands dots as namespace + separators. *) + +let () = Reserved_namespaces.reserve "baz.qux" + +let x = (42 [@baz]) +[%%expect{| +Line _, characters 14-17: +Error: Attribute `baz' was silently dropped +|}] + +let x = (42 [@baz.qux]) +[%%expect{| +val x : int = 42 +|}] + +let x = (42 [@baz.qux.quux]) +[%%expect{| +val x : int = 42 +|}] + +let x = (42 [@baz.qux_not_proper_sub_namespace]) +[%%expect{| +Line _, characters 14-46: +Error: Attribute `baz.qux_not_proper_sub_namespace' was silently dropped +|}] + +(* You can reserve multiple subnamespaces under the same namespace *) + +let () = Reserved_namespaces.reserve "baz.qux2" + +let x = (42 [@baz.qux]) +let x = (42 [@baz.qux2]) +[%%expect{| +val x : int = 42 +val x : int = 42 +|}] + +let x = (42 [@baz.qux3]) +[%%expect{| +Line _, characters 14-22: +Error: Attribute `baz.qux3' was silently dropped +|}] + +(* Testing flags *) + +let flag = Attribute.declare_flag "flag" Attribute.Context.expression +[%%expect{| +val flag : expression Attribute.flag = +|}] + +let replace_flagged = object + inherit Ast_traverse.map as super + + method! expression e = + match Attribute.has_flag_res flag e with + | Ok true -> Ast_builder.Default.estring ~loc:e.pexp_loc "Found flag" + | Ok false -> super#expression e + | Error (err, _) -> Ast_builder.Default.estring ~loc:e.pexp_loc (Location.Error.message err) +end +[%%expect{| +val replace_flagged : Ast_traverse.map = +|}] + +let () = + Driver.register_transformation "" ~impl:replace_flagged#structure + +let e1 = "flagged" [@flag] +[%%expect{| +val e1 : string = "Found flag" +|}] + +let e1 = "flagged" [@flag 12] +[%%expect{| +val e1 : string = "[] expected" +|}] diff --git a/test/driver/attributes/test_510.ml b/test/driver/attributes/test_510.ml index d8b6bed7e..7f96affa5 100644 --- a/test/driver/attributes/test_510.ml +++ b/test/driver/attributes/test_510.ml @@ -103,3 +103,129 @@ type t2 = < > Line _, characters 17-20: Error: Attribute `foo' was not used |}] + +(* Reserved Namespaces *) + +(* ppxlib checks that unreserved attributes aren't dropped *) + +let x = (42 [@bar]) +[%%expect{| + +Line _, characters 14-17: +Error: Attribute `bar' was silently dropped +|}] + +let x = (42 [@bar.baz]) +[%%expect{| + +Line _, characters 14-21: +Error: Attribute `bar.baz' was silently dropped +|}] + +(* But reserving a namespace disables those checks. *) + +let () = Reserved_namespaces.reserve "bar" + +let x = (42 [@bar]) +let x = (42 [@bar.baz]) +[%%expect{| + +val x : int = 42 + +val x : int = 42 +|}] + +let x = (42 [@bar_not_proper_sub_namespace]) +[%%expect{| + +Line _, characters 14-42: +Error: Attribute `bar_not_proper_sub_namespace' was silently dropped +|}] + +(* The namespace reservation process understands dots as namespace + separators. *) + +let () = Reserved_namespaces.reserve "baz.qux" + +let x = (42 [@baz]) +[%%expect{| + +Line _, characters 14-17: +Error: Attribute `baz' was silently dropped +|}] + +let x = (42 [@baz.qux]) +[%%expect{| + +val x : int = 42 +|}] + +let x = (42 [@baz.qux.quux]) +[%%expect{| + +val x : int = 42 +|}] + +let x = (42 [@baz.qux_not_proper_sub_namespace]) +[%%expect{| + +Line _, characters 14-46: +Error: Attribute `baz.qux_not_proper_sub_namespace' was silently dropped +|}] + +(* You can reserve multiple subnamespaces under the same namespace *) + +let () = Reserved_namespaces.reserve "baz.qux2" + +let x = (42 [@baz.qux]) +let x = (42 [@baz.qux2]) +[%%expect{| + +val x : int = 42 + +val x : int = 42 +|}] + +let x = (42 [@baz.qux3]) +[%%expect{| + +Line _, characters 14-22: +Error: Attribute `baz.qux3' was silently dropped +|}] + +(* Testing flags *) + +let flag = Attribute.declare_flag "flag" Attribute.Context.expression +[%%expect{| + +val flag : expression Attribute.flag = +|}] + +let replace_flagged = object + inherit Ast_traverse.map as super + + method! expression e = + match Attribute.has_flag_res flag e with + | Ok true -> Ast_builder.Default.estring ~loc:e.pexp_loc "Found flag" + | Ok false -> super#expression e + | Error (err, _) -> Ast_builder.Default.estring ~loc:e.pexp_loc (Location.Error.message err) +end +[%%expect{| + +val replace_flagged : Ast_traverse.map = +|}] + +let () = + Driver.register_transformation "" ~impl:replace_flagged#structure + +let e1 = "flagged" [@flag] +[%%expect{| + +val e1 : string = "Found flag" +|}] + +let e1 = "flagged" [@flag 12] +[%%expect{| + +val e1 : string = "[] expected" +|}] diff --git a/test/driver/transformations/test.ml b/test/driver/transformations/test.ml index 48ea804b4..1f13cfadf 100644 --- a/test/driver/transformations/test.ml +++ b/test/driver/transformations/test.ml @@ -56,17 +56,17 @@ let () = [%%expect{| |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop] [%%expect{| - : string = "-\n" |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop.Truc] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop.Truc] [%%expect{| - : string = "Truc\n" |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop.Truc.Bidule] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop.Truc.Bidule] [%%expect{| - : string = "Truc.Bidule\n" |}] @@ -89,17 +89,17 @@ let () = [%%expect{| |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop_ctxt] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt] [%%expect{| - : string = "-\n" |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop_ctxt.Truc] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt.Truc] [%%expect{| - : string = "Truc\n" |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop_ctxt.Truc.Bidule] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt.Truc.Bidule] [%%expect{| - : string = "Truc.Bidule\n" |}] diff --git a/test/driver/transformations/test_412.ml b/test/driver/transformations/test_412.ml index d7ea35a2e..d386d438a 100644 --- a/test/driver/transformations/test_412.ml +++ b/test/driver/transformations/test_412.ml @@ -56,17 +56,17 @@ let () = [%%expect{| |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop] [%%expect{| - : string = "-\n" |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop.Truc] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop.Truc] [%%expect{| - : string = "Truc\n" |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop.Truc.Bidule] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop.Truc.Bidule] [%%expect{| - : string = "Truc.Bidule\n" |}] @@ -89,17 +89,17 @@ let () = [%%expect{| |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop_ctxt] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt] [%%expect{| - : string = "-\n" |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop_ctxt.Truc] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt.Truc] [%%expect{| - : string = "Truc\n" |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop_ctxt.Truc.Bidule] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt.Truc.Bidule] [%%expect{| - : string = "Truc.Bidule\n" |}] diff --git a/test/driver/transformations/test_510.ml b/test/driver/transformations/test_510.ml index 596c43b74..cd8f0d20b 100644 --- a/test/driver/transformations/test_510.ml +++ b/test/driver/transformations/test_510.ml @@ -56,19 +56,19 @@ let () = [%%expect{| |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop] [%%expect{| - : string = "-\n" |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop.Truc] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop.Truc] [%%expect{| - : string = "Truc\n" |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop.Truc.Bidule] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop.Truc.Bidule] [%%expect{| - : string = "Truc.Bidule\n" @@ -92,19 +92,19 @@ let () = [%%expect{| |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop_ctxt] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt] [%%expect{| - : string = "-\n" |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop_ctxt.Truc] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt.Truc] [%%expect{| - : string = "Truc\n" |}] -let _ = Caml.Printf.sprintf "%s\n" [%plop_ctxt.Truc.Bidule] +let _ = Stdlib.Printf.sprintf "%s\n" [%plop_ctxt.Truc.Bidule] [%%expect{| - : string = "Truc.Bidule\n" diff --git a/test/metaquot/test.ml b/test/metaquot/test.ml index 148ab4ade..026e8dc2e 100644 --- a/test/metaquot/test.ml +++ b/test/metaquot/test.ml @@ -292,6 +292,243 @@ let _ = [%sig: include S] loc_ghost = true}}] |}] +(* attributes *) + +let _ = + let e = [%expr (() [@attr1])] in + [%expr [%e e] [@attr2]].pexp_attributes +[%%expect{| +- : Ppxlib_ast.Ast.attributes = +[{Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr1"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + {Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr2"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + +let _ = + let p = [%pat? (() [@attr1])] in + [%pat? [%p p] [@attr2]].ppat_attributes +[%%expect{| +- : Ppxlib_ast.Ast.attributes = +[{Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr1"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + {Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr2"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + +let _ = + let t = [%type: (unit [@attr1])] in + [%type: [%t t] [@attr2]].ptyp_attributes +[%%expect{| +- : Ppxlib_ast.Ast.attributes = +[{Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr1"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + {Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr2"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + +let _ = + let extract_module_M m = + match m with + | [%stri module M = [%m? m]] -> m + | _ -> assert false + in + let m = extract_module_M [%stri module M = (struct end [@attr1])] in + (extract_module_M [%stri module M = [%m m] [@attr2]]).pmod_attributes +[%%expect{| +- : Ppxlib_ast.Ast.attributes = +[{Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr1"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + {Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr2"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + +let _ = + let extract_module_ty_S s = + match s with + | [%stri module type S = [%m? s]] -> s + | _ -> assert false + in + let s = extract_module_ty_S [%stri module type S = (sig end [@attr1])] in + (extract_module_ty_S [%stri module type S = [%m s] [@attr2]]).pmty_attributes +[%%expect{| +- : Ppxlib_ast.Ast.attributes = +[{Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr1"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + {Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr2"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + (* mistyped escapes (not producing ASTs at all) *) let _ = [%expr [%e ()]] @@ -328,3 +565,40 @@ Line _, characters 21-23: Error: This expression should not be a unit literal, the expected type is Ppxlib_ast.Ast.signature_item |}] + +(* mistyped escapes (not producing ASTs at all) with attributes *) + +let _ = [%expr [%e ()] [@attr]] +[%%expect{| +Line _, characters 19-21: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.expression +|}] + +let _ = [%pat? [%p ()] [@attr]] +[%%expect{| +Line _, characters 19-21: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.pattern +|}] + +let _ = [%type: [%t ()] [@attr]] +[%%expect{| +Line _, characters 20-22: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.core_type +|}] + +let _ = [%stri module M = [%m ()] [@attr]] +[%%expect{| +Line _, characters 30-32: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.module_expr +|}] + +let _ = [%sigi: module type M = [%m ()] [@attr]] +[%%expect{| +Line _, characters 36-38: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.module_type +|}] diff --git a/test/metaquot/test_510.ml b/test/metaquot/test_510.ml index a4cae3339..4b6e64d18 100644 --- a/test/metaquot/test_510.ml +++ b/test/metaquot/test_510.ml @@ -292,6 +292,243 @@ let _ = [%sig: include S] loc_ghost = true}}] |}] +(* attributes *) + +let _ = + let e = [%expr (() [@attr1])] in + [%expr [%e e] [@attr2]].pexp_attributes +[%%expect{| +- : Ppxlib_ast.Ast.attributes = +[{Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr1"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + {Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr2"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + +let _ = + let p = [%pat? (() [@attr1])] in + [%pat? [%p p] [@attr2]].ppat_attributes +[%%expect{| +- : Ppxlib_ast.Ast.attributes = +[{Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr1"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + {Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr2"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + +let _ = + let t = [%type: (unit [@attr1])] in + [%type: [%t t] [@attr2]].ptyp_attributes +[%%expect{| +- : Ppxlib_ast.Ast.attributes = +[{Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr1"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + {Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr2"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + +let _ = + let extract_module_M m = + match m with + | [%stri module M = [%m? m]] -> m + | _ -> assert false + in + let m = extract_module_M [%stri module M = (struct end [@attr1])] in + (extract_module_M [%stri module M = [%m m] [@attr2]]).pmod_attributes +[%%expect{| +- : Ppxlib_ast.Ast.attributes = +[{Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr1"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + {Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr2"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + +let _ = + let extract_module_ty_S s = + match s with + | [%stri module type S = [%m? s]] -> s + | _ -> assert false + in + let s = extract_module_ty_S [%stri module type S = (sig end [@attr1])] in + (extract_module_ty_S [%stri module type S = [%m s] [@attr2]]).pmty_attributes +[%%expect{| +- : Ppxlib_ast.Ast.attributes = +[{Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr1"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + {Ppxlib_ast.Ast.attr_name = + {Ppxlib_ast.Ast.txt = "attr2"; + loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}; + attr_payload = Ppxlib_ast.Ast.PStr []; + attr_loc = + {Ppxlib_ast.Ast.loc_start = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_end = + {Ppxlib_ast.Ast.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; + pos_cnum = -1}; + loc_ghost = true}}] +|}] + (* mistyped escapes (not producing ASTs at all) *) let _ = [%expr [%e ()]] @@ -332,3 +569,45 @@ Line _, characters 21-23: Error: This expression should not be a unit literal, the expected type is Ppxlib_ast.Ast.signature_item |}] + +(* mistyped escapes (not producing ASTs at all) with attributes *) + +let _ = [%expr [%e ()] [@attr]] +[%%expect{| + +Line _, characters 19-21: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.expression +|}] + +let _ = [%pat? [%p ()] [@attr]] +[%%expect{| + +Line _, characters 19-21: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.pattern +|}] + +let _ = [%type: [%t ()] [@attr]] +[%%expect{| + +Line _, characters 20-22: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.core_type +|}] + +let _ = [%stri module M = [%m ()] [@attr]] +[%%expect{| + +Line _, characters 30-32: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.module_expr +|}] + +let _ = [%sigi: module type M = [%m ()] [@attr]] +[%%expect{| + +Line _, characters 36-38: +Error: This expression should not be a unit literal, the expected type is + Ppxlib_ast.Ast.module_type +|}]