diff --git a/CHANGELOG.md b/CHANGELOG.md index e2af324..5eda7b4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,9 +1,10 @@ -## [1.5.1] -- 2024-07-04 +## [1.5.1] -- 2024-07-07 ### Changed - Outputs entry ids on the stack when reporting static vs. dynamic scope mismatch failure. - Promotes `val snapshot : unit -> unit` to the generic interface, implemented as no-op in the flushing backend. +- Does not try to debug module bindings. ## [1.5.0] -- 2024-03-20 diff --git a/ppx_minidebug.ml b/ppx_minidebug.ml index 17e94b2..11369fe 100644 --- a/ppx_minidebug.ml +++ b/ppx_minidebug.ml @@ -413,6 +413,16 @@ let rec pick ~typ ?alt_typ () = | _ -> typ) | _ -> typ +let rec has_unprintable_type typ = + match typ.ptyp_desc with + | Ptyp_alias (typ, _) | Ptyp_poly (_, typ) -> has_unprintable_type typ + | Ptyp_any | Ptyp_var _ | Ptyp_package _ | Ptyp_extension _ -> true + | Ptyp_arrow (_, arg, ret) -> + (* TODO: maybe add Ptyp_object, Ptyp_class? *) + has_unprintable_type arg || has_unprintable_type ret + | Ptyp_tuple args | Ptyp_constr (_, args) -> List.exists has_unprintable_type args + | _ -> false + let bound_patterns ~alt_typ pat = let rec loop ?alt_typ pat = let loc = pat.ppat_loc in @@ -422,8 +432,8 @@ let bound_patterns ~alt_typ pat = | _ -> (alt_typ, pat) in match (typ, pat) with - | ( Some { ptyp_desc = Ptyp_any | Ptyp_var _ | Ptyp_package _ | Ptyp_extension _; _ }, - { ppat_desc = Ppat_var _ | Ppat_alias (_, _); _ } ) -> + | Some t, { ppat_desc = Ppat_var _ | Ppat_alias (_, _); _ } + when has_unprintable_type t -> (* Skip abstract types and types unlikely to have derivable printers. *) (A.ppat_any ~loc, []) | Some typ, ({ ppat_desc = Ppat_var descr_loc | Ppat_alias (_, descr_loc); _ } as pat) @@ -936,7 +946,8 @@ let extract_type ?default ~alt_typ exp = [%type: [%t typ] Lazy.t] with Not_transforming -> ( match typ with Some typ -> typ | None -> raise Not_transforming)) - | Some { ptyp_desc = Ptyp_any | Ptyp_var _ | Ptyp_extension _; _ }, _ -> + | Some { ptyp_desc = Ptyp_any | Ptyp_var _ | Ptyp_package _ | Ptyp_extension _; _ }, _ + -> raise Not_transforming | Some typ, _ -> typ | None, _ when use_default -> diff --git a/test/test_expect_test.ml b/test/test_expect_test.ml index 1c3879c..3b7ad48 100644 --- a/test/test_expect_test.ml +++ b/test/test_expect_test.ml @@ -3579,9 +3579,7 @@ let%expect_test "flame graph" = with End_of_file -> ()); close_in file; let output = [%expect.output] in - let output = - Str.global_replace (Str.regexp {|[0-9]+\.[0-9]*%|}) "N.NNNN%" output - in + let output = Str.global_replace (Str.regexp {|[0-9]+\.[0-9]*%|}) "N.NNNN%" output in print_endline output; [%expect {| @@ -3684,71 +3682,95 @@ let%expect_test "flame graph reduced ToC" = with End_of_file -> ()); close_in file; let output = [%expect.output] in - let output = - Str.global_replace (Str.regexp {|[0-9]+\.[0-9]*%|}) "N.NNNN%" output - in + let output = Str.global_replace (Str.regexp {|[0-9]+\.[0-9]*%|}) "N.NNNN%" output in print_endline output; [%expect {| -
"test/test_expect_test.ml":3670:26: loop
-
-
-
-
-
-
-
-
-
-
-
|}] +
"test/test_expect_test.ml":3668:26: loop
+
+
+
+
+
+
+
+
+
+
+
+ |}] + +let%expect_test "%debug_show skip module bindings" = + let module Debug_runtime = (val Minidebug_runtime.debug ~values_first_mode:true ()) in + let%track_sexp bar ?(rt : (module Minidebug_runtime.Debug_runtime) option) (x : int) : + int = + let y : int = x + 1 in + let module Debug_runtime = + (val match rt with None -> (module Debug_runtime : Minidebug_runtime.Debug_runtime) | Some rt -> rt) + in + let z = y * 2 in + z - 1 + in + let () = print_endline @@ Int.to_string @@ bar ~rt:(module Debug_runtime) 7 in + [%expect + {| + BEGIN DEBUG SESSION + bar = 15 + ├─"test/test_expect_test.ml":3755:21 + ├─x = 7 + ├─y = 8 + │ └─"test/test_expect_test.ml":3757:8 + └─ Some rt + └─"test/test_expect_test.ml":3759:103 + 15 + |}]