diff --git a/config/cfg_ppx.ml b/config/cfg_ppx.ml index 632d039..7115f66 100644 --- a/config/cfg_ppx.ml +++ b/config/cfg_ppx.ml @@ -107,6 +107,45 @@ let apply_config_on_types (tds : type_declaration list) = | _ -> Some td) tds +let apply_config_on_cases (cases : cases) = + List.filter + (fun case -> + if should_keep case.pc_rhs.pexp_attributes = `keep then true else false) + cases + +let rec apply_config_on_expression (exp : expression) = + let pexp_desc = + match exp.pexp_desc with + | Pexp_try (exp, cases) -> + let exp = apply_config_on_expression exp in + let cases = apply_config_on_cases cases in + Pexp_try (exp, cases) + | Pexp_match (exp, cases) -> + let exp = apply_config_on_expression exp in + let cases = apply_config_on_cases cases in + Pexp_match (exp, cases) + | Pexp_fun (arg_label, exp_opt, pat, exp) -> + let exp = apply_config_on_expression exp in + Pexp_fun (arg_label, exp_opt, pat, exp) + | Pexp_function cases -> + let cases = apply_config_on_cases cases in + Pexp_function cases + | Pexp_let (rec_flag, vbs, exp) -> + let exp = apply_config_on_expression exp in + Pexp_let (rec_flag, vbs, exp) + | _ -> exp.pexp_desc + in + let { pexp_loc; pexp_loc_stack; pexp_attributes; _ } = exp in + { pexp_loc; pexp_loc_stack; pexp_attributes; pexp_desc } + +let apply_config_on_value_bindings (vbs : value_binding list) = + List.map + (fun vb -> + let { pvb_loc; pvb_attributes; pvb_pat; pvb_expr } = vb in + let _pvb_expr = apply_config_on_expression pvb_expr in + { pvb_loc; pvb_attributes; pvb_pat; pvb_expr = _pvb_expr }) + vbs + let apply_config_on_structure_item stri = try match stri.pstr_desc with @@ -119,9 +158,10 @@ let apply_config_on_structure_item stri = | Pstr_eval (_, attrs) | Pstr_module { pmb_attributes = attrs; _ } -> if should_keep attrs = `keep then Some stri else None - | Pstr_value (_, vbs) -> + | Pstr_value (recflag, vbs) -> if should_keep_many vbs (fun vb -> vb.pvb_attributes) = `keep then - Some stri + let vbs = apply_config_on_value_bindings vbs in + Some { stri with pstr_desc = Pstr_value (recflag, vbs) } else None | Pstr_type (recflag, tds) -> if should_keep_many tds (fun td -> td.ptype_attributes) = `keep then diff --git a/config/ppx.t/cond_type_var_constructor.ml b/config/ppx.t/cond_type_var_constructor.ml index 7301e3a..b19f895 100644 --- a/config/ppx.t/cond_type_var_constructor.ml +++ b/config/ppx.t/cond_type_var_constructor.ml @@ -1,22 +1,27 @@ type band = | Rush | Yes - | KingCrimson [@config (made_up = true)] + | KingCrimson [@config (made_up = "false")] -(* this pattern matching is exhaustive because the config removes the - KingCrimson constructor *) let best_band_in_the_world x = match x with | Rush -> true | Yes -> false + | KingCrimson -> false [@config (made_up = "false")] + +and worst_band_in_the_world = function +| Rush -> false +| Yes -> false +| KingCrimson -> true [@config (made_up = "false")] type band_polyvar = [ | `Rush | `Yes - | `KingCrimson [@config (made_up=true)] + | `KingCrimson [@config (made_up = true)] ] let the_best_band_in_the_world (x: band_polyvar) = match x with | `Rush -> true | `Yes -> false + | `KingCrimson -> false [@config (made_up = true)] diff --git a/config/ppx.t/cond_value.ml b/config/ppx.t/cond_value.ml index 98d8f97..27457d1 100644 --- a/config/ppx.t/cond_value.ml +++ b/config/ppx.t/cond_value.ml @@ -4,5 +4,11 @@ let best_band_in_the_world () = "rush" let print_band () = print_endline (best_band_in_the_world ()) [@@config (made_up = true)] +(* Applying config on a single value binding + should remove all value bindings. *) +let () = print_band () and +print_name1 name = print_endline name +[@@config (made_up = true)] + (** ignored comments *) let hello = "world" diff --git a/config/ppx.t/run.t b/config/ppx.t/run.t index c77c838..6866027 100644 --- a/config/ppx.t/run.t +++ b/config/ppx.t/run.t @@ -120,6 +120,10 @@ all ((target_os = "windows"), (target_arch = "arm"))] let () = Printf.printf "sys=%s env=%s" Sys.name Env.name + $ dune clean + $ made_up=false dune exec ./main.exe + sys=unix env=unknown + $ dune clean $ dune exec ./main.exe sys=unix env=unknown