Skip to content

WIP: Improve deriving inline so it can be used alongside other ppx-es #541

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Draft
wants to merge 3 commits into
base: main
Choose a base branch
from
Draft

WIP: Improve deriving inline so it can be used alongside other ppx-es #541

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
3 commits
Select commit Hold shift + click to select a range
b41146e
Add test for -no-corrections
NathanReb Dec 4, 2024
a539cfa
Implement -no-corrections
NathanReb Dec 6, 2024
6426dc0
Mark deriving.end attributes as seen in -no-corrections mode
NathanReb Dec 10, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
10 changes: 10 additions & 0 deletions src/code_matcher.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -58,6 +58,13 @@ struct
in
loop [] l

let see_end_marker item =
match Attribute.Floating.convert_res [ M.end_marker ] item with
| Ok None -> Ok ()
| Ok (Some ()) -> Ok ()
| Error e -> Error e
| exception Failure _ -> Ok ()

let remove_loc =
object
inherit Ast_traverse.map
Expand Down Expand Up @@ -212,3 +219,6 @@ let match_signature_res = Sig.do_match
let match_signature ~pos ~expected ~mismatch_handler l =
match_signature_res ~pos ~expected ~mismatch_handler l
|> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err)

let see_end_marker_str = Str.see_end_marker
let see_end_marker_sig = Sig.see_end_marker
9 changes: 9 additions & 0 deletions src/code_matcher.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -39,3 +39,12 @@ val match_signature :
signature ->
unit
(** Same for signatures *)

(** The following functions mark [@@@deriving.end] as seen. Useful when
purposefully ignoring correction based transformations. *)

val see_end_marker_str :
structure_item -> (unit, Location.Error.t NonEmptyList.t) result

val see_end_marker_sig :
signature_item -> (unit, Location.Error.t NonEmptyList.t) result
74 changes: 58 additions & 16 deletions src/context_free.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -462,6 +462,35 @@ let handle_attr_inline attrs ~convert_exn ~item ~expanded_item ~loc ~base_ctxt
let error_item = [ convert_exn exn ] in
return (error_item :: acc)))

let handle_attr_group_inline_expect attrs rf ~items ~expanded_items ~loc
~base_ctxt ~embed_errors ~convert_exn ~no_corrections =
if no_corrections then
(* Mark expect attributes as seen *)
List.fold_left attrs ~init:(return ())
~f:(fun acc (Rule.Attr_group_inline.T group) ->
acc >>= fun () ->
get_group group.attribute items >>= fun _ ->
get_group group.attribute expanded_items >>= fun _ -> return ())
>>= fun () -> return []
else
handle_attr_group_inline attrs rf ~items ~expanded_items ~loc ~base_ctxt
~embed_errors ~convert_exn

let handle_attr_inline_expect attrs ~convert_exn ~item ~expanded_item ~loc
~base_ctxt ~embed_errors ~no_corrections =
if no_corrections then
(* Mark expect attributes as seen *)
List.fold_left attrs ~init:(return ()) ~f:(fun acc (Rule.Attr_inline.T a) ->
acc >>= fun () ->
Attribute.get_res a.attribute item |> of_result ~default:None
>>= fun _ ->
Attribute.get_res a.attribute expanded_item |> of_result ~default:None
>>= fun _ -> return ())
>>= fun () -> return []
else
handle_attr_inline attrs ~item ~expanded_item ~loc ~base_ctxt ~embed_errors
~convert_exn

module Expect_mismatch_handler = struct
type t = {
f : 'a. 'a Attribute.Floating.Context.t -> Location.t -> 'a list -> unit;
Expand All @@ -471,8 +500,8 @@ module Expect_mismatch_handler = struct
end

class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
?(generated_code_hook = Generated_code_hook.nop) ?(embed_errors = false) rules
=
?(generated_code_hook = Generated_code_hook.nop) ?(embed_errors = false)
?(no_corrections = false) rules =
let hook = generated_code_hook in

let special_functions =
Expand Down Expand Up @@ -546,6 +575,15 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
let map_nodes = map_nodes ~hook ~embed_errors in
let handle_attr_group_inline = handle_attr_group_inline ~embed_errors in
let handle_attr_inline = handle_attr_inline ~embed_errors in
let handle_attr_group_inline_expect =
handle_attr_group_inline_expect ~no_corrections ~embed_errors
in
let handle_attr_inline_expect =
handle_attr_inline_expect ~no_corrections ~embed_errors
in
let see_end_marker f item =
(if no_corrections then f item else Ok ()) |> of_result ~default:()
in

object (self)
inherit Ast_traverse.map_with_expansion_context_and_errors as super
Expand Down Expand Up @@ -748,6 +786,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
| [] -> return []
| item :: rest -> (
let loc = item.pstr_loc in
see_end_marker Code_matcher.see_end_marker_str item >>= fun () ->
match item.pstr_desc with
| Pstr_extension (ext, attrs) -> (
let extension_point_loc = item.pstr_loc in
Expand Down Expand Up @@ -780,8 +819,8 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
handle_attr_group_inline attr_str_type_decls rf ~items:tds
~expanded_items:exp_tds ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_group_inline attr_str_type_decls_expect rf
~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt
handle_attr_group_inline_expect attr_str_type_decls_expect
rf ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt
~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
Expand All @@ -790,7 +829,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
handle_attr_inline attr_str_module_type_decls ~item:mtd
~expanded_item:exp_mtd ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_inline attr_str_module_type_decls_expect
handle_attr_inline_expect attr_str_module_type_decls_expect
~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt
~convert_exn
>>= fun expect_items ->
Expand All @@ -800,7 +839,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
handle_attr_inline attr_str_type_exts ~item:te
~expanded_item:exp_te ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_inline attr_str_type_exts_expect ~item:te
handle_attr_inline_expect attr_str_type_exts_expect ~item:te
~expanded_item:exp_te ~loc ~base_ctxt ~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
Expand All @@ -809,8 +848,9 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
handle_attr_inline attr_str_exceptions ~item:ec
~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_inline attr_str_exceptions_expect ~item:ec
~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn
handle_attr_inline_expect attr_str_exceptions_expect
~item:ec ~expanded_item:exp_ec ~loc ~base_ctxt
~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
~rest ~in_generated_code
Expand All @@ -819,7 +859,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
~items:cds ~expanded_items:exp_cds ~loc ~base_ctxt
~convert_exn
>>= fun extra_items ->
handle_attr_group_inline attr_str_class_decls_expect
handle_attr_group_inline_expect attr_str_class_decls_expect
Nonrecursive ~items:cds ~expanded_items:exp_cds ~loc
~base_ctxt ~convert_exn
>>= fun expect_items ->
Expand Down Expand Up @@ -857,6 +897,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
| [] -> return []
| item :: rest -> (
let loc = item.psig_loc in
see_end_marker Code_matcher.see_end_marker_sig item >>= fun () ->
match item.psig_desc with
| Psig_extension (ext, attrs) -> (
let extension_point_loc = item.psig_loc in
Expand Down Expand Up @@ -889,8 +930,8 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
handle_attr_group_inline attr_sig_type_decls rf ~items:tds
~expanded_items:exp_tds ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_group_inline attr_sig_type_decls_expect rf
~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt
handle_attr_group_inline_expect attr_sig_type_decls_expect
rf ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt
~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
Expand All @@ -899,7 +940,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
handle_attr_inline attr_sig_module_type_decls ~item:mtd
~expanded_item:exp_mtd ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_inline attr_sig_module_type_decls_expect
handle_attr_inline_expect attr_sig_module_type_decls_expect
~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt
~convert_exn
>>= fun expect_items ->
Expand All @@ -909,7 +950,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
handle_attr_inline attr_sig_type_exts ~item:te
~expanded_item:exp_te ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_inline attr_sig_type_exts_expect ~item:te
handle_attr_inline_expect attr_sig_type_exts_expect ~item:te
~expanded_item:exp_te ~loc ~base_ctxt ~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
Expand All @@ -918,8 +959,9 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
handle_attr_inline attr_sig_exceptions ~item:ec
~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn
>>= fun extra_items ->
handle_attr_inline attr_sig_exceptions_expect ~item:ec
~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn
handle_attr_inline_expect attr_sig_exceptions_expect
~item:ec ~expanded_item:exp_ec ~loc ~base_ctxt
~convert_exn
>>= fun expect_items ->
with_extra_items expanded_item ~extra_items ~expect_items
~rest ~in_generated_code
Expand All @@ -928,7 +970,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
~items:cds ~expanded_items:exp_cds ~loc ~base_ctxt
~convert_exn
>>= fun extra_items ->
handle_attr_group_inline attr_sig_class_decls_expect
handle_attr_group_inline_expect attr_sig_class_decls_expect
Nonrecursive ~items:cds ~expanded_items:exp_cds ~loc
~base_ctxt ~convert_exn
>>= fun expect_items ->
Expand Down
1 change: 1 addition & 0 deletions src/context_free.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -166,6 +166,7 @@ class map_top_down :
?generated_code_hook:
Generated_code_hook.t (* default: Generated_code_hook.nop *) ->
?embed_errors:bool ->
?no_corrections:bool ->
Rule.t list ->
object
inherit Ast_traverse.map_with_expansion_context_and_errors
Expand Down
Loading
Loading