From f18a8aef4797695e963f1ba8a8119b30c61da0f5 Mon Sep 17 00:00:00 2001 From: Lukasz Stafiniak Date: Sat, 27 Jan 2024 23:00:05 +0100 Subject: [PATCH] Fixes #9, yay! Tuple and record patterns without aliases Unfortunately, `value_first_mode:true` doesn't give as nice results (yet). --- CHANGELOG.md | 2 +- ppx_minidebug.ml | 74 +++++++++++++++++++++++++++++-------- test/test_expect_test.ml | 80 ++++++++++++++++++++++++++++++++++++++++ 3 files changed, 140 insertions(+), 16 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1c1a479..720929d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,7 +11,7 @@ - Rename `debug_html` to `debug_file`, since it now supports both HTML and Markdown. Take file name/path without a suffix. - Refactored PrintBox configuration, smaller footprint and allowing control over the backends. - Changed `highlighted_roots` to a more general `prune_upto`: prune to only the highlighted boxes up to the given depth. -- TODO: Fixes #9: handle tuple and record patterns by automatically wrapping in an alias pattern. +- TODO: Fixes #9: handle tuple and record patterns. - TODO: Adresses #5: less reliance on the concrete AST data structures. ## [0.9.0] -- 2024-01-18 diff --git a/ppx_minidebug.ml b/ppx_minidebug.ml index bb30492..3f4a4c9 100644 --- a/ppx_minidebug.ml +++ b/ppx_minidebug.ml @@ -1,11 +1,29 @@ open Ppxlib module A = Ast_builder.Default +let rec last_ident = function + | Lident id -> id + | Ldot (_, id) -> id + | Lapply (_, lid) -> last_ident lid + let rec pat2descr ~default pat = let loc = pat.ppat_loc in match pat.ppat_desc with | Ppat_constraint (pat', _) -> pat2descr ~default pat' | Ppat_alias (_, ident) | Ppat_var ident -> ident + | Ppat_tuple tups -> + let dscrs = List.map (fun p -> (pat2descr ~default:"_" p).txt) tups in + { txt = "(" ^ String.concat ", " dscrs ^ ")"; loc } + | Ppat_record (fields, _) -> + let dscrs = + List.map + (fun (id, p) -> + let label = last_ident id.txt in + let pat = (pat2descr ~default:"_" p).txt in + if String.equal label pat then pat else label ^ "=" ^ pat) + fields + in + { txt = "{" ^ String.concat "; " dscrs ^ "}"; loc } | _ -> { txt = default; loc } let rec pat2expr pat = @@ -151,7 +169,7 @@ let rec expand_fun body = function } let bound_patterns ~alt_typ pat = - let bind_pat, bound = + let rec loop ~alt_typ pat = match (alt_typ, pat) with | ( _, [%pat? @@ -161,10 +179,37 @@ let bound_patterns ~alt_typ pat = | Some typ, ({ ppat_desc = Ppat_var descr_loc | Ppat_alias (_, descr_loc); _ } as pat) -> (A.ppat_var ~loc:pat.ppat_loc descr_loc, [ (descr_loc, pat, typ) ]) + | ( _, + [%pat? + ([%p? { ppat_desc = Ppat_tuple pats; ppat_loc; _ }] : + [%t? { ptyp_desc = Ptyp_tuple typs; _ }])] ) -> + (* TODO: ideally we should combine with the alt_typ information if present. *) + let pats, bindings = + List.split @@ List.map2 (fun pat typ -> loop ~alt_typ:(Some typ) pat) pats typs + in + (A.ppat_tuple ~loc:ppat_loc pats, List.concat bindings) + | ( Some { ptyp_desc = Ptyp_tuple typs; _ }, + { ppat_desc = Ppat_tuple pats; ppat_loc; _ } ) -> + let pats, bindings = + List.split @@ List.map2 (fun pat typ -> loop ~alt_typ:(Some typ) pat) pats typs + in + (A.ppat_tuple ~loc:ppat_loc pats, List.concat bindings) + | _, { ppat_desc = Ppat_tuple pats; ppat_loc; _ } -> + let pats, bindings = + List.split @@ List.map (fun pat -> loop ~alt_typ:None pat) pats + in + (A.ppat_tuple ~loc:ppat_loc pats, List.concat bindings) + | _, { ppat_desc = Ppat_record (fields, closed); ppat_loc; _ } -> + let pats, bindings = + List.split @@ List.map (fun (_, pat) -> loop ~alt_typ:None pat) fields + in + let fields = List.map2 (fun (id, _) pat -> (id, pat)) fields pats in + (A.ppat_record ~loc:ppat_loc fields closed, List.concat bindings) | _ -> (A.ppat_any ~loc:pat.ppat_loc, []) in + let bind_pat, bound = loop ~alt_typ pat in let loc = pat.ppat_loc in - A.ppat_alias ~loc bind_pat { txt = "__res"; loc }, bound + (A.ppat_alias ~loc bind_pat { txt = "__res"; loc }, bound) let debug_fun callback ?descr_loc ?alt_typ exp = let args, body, typ_opt2 = collect_fun [] exp in @@ -240,22 +285,20 @@ let debug_fun callback ?descr_loc ?alt_typ exp = let debug_binding callback vb = let pat = vb.pvb_pat in let loc = vb.pvb_loc in - let descr_loc, alt_typ = - match (vb.pvb_pat, vb.pvb_expr) with - | ( [%pat? - ([%p? { ppat_desc = Ppat_var descr_loc | Ppat_alias (_, descr_loc); _ }] : - [%t? typ])], - _ ) -> - (descr_loc, Some typ) - | ( { ppat_desc = Ppat_var descr_loc | Ppat_alias (_, descr_loc); _ }, - [%expr ([%e? _exp] : [%t? typ])] ) -> - (descr_loc, Some typ) - | { ppat_desc = Ppat_var descr_loc | Ppat_alias (_, descr_loc); _ }, _ -> - (descr_loc, None) - | _ -> raise Not_transforming + let alt_typ = + match vb.pvb_expr with [%expr ([%e? _exp] : [%t? typ])] -> Some typ | _ -> None in match vb.pvb_expr.pexp_desc with | Pexp_newtype _ | Pexp_fun _ -> + let descr_loc = + match pat with + | [%pat? + ([%p? { ppat_desc = Ppat_var descr_loc | Ppat_alias (_, descr_loc); _ }] : + [%t? _])] -> + descr_loc + | { ppat_desc = Ppat_var descr_loc | Ppat_alias (_, descr_loc); _ } -> descr_loc + | _ -> raise Not_transforming + in { vb with pvb_expr = debug_fun callback ~descr_loc ?alt_typ vb.pvb_expr } | _ -> let result, bound = bound_patterns ~alt_typ pat in @@ -272,6 +315,7 @@ let debug_binding callback vb = [%e e2]]) [%expr ()] in + let descr_loc = pat2descr ~default:"__val" pat in let exp = [%expr let __entry_id = Debug_runtime.get_entry_id () in diff --git a/test/test_expect_test.ml b/test/test_expect_test.ml index 3291cb0..cf08750 100644 --- a/test/test_expect_test.ml +++ b/test/test_expect_test.ml @@ -1164,3 +1164,83 @@ let%expect_test "%track_show PrintBox values_first_mode to stdout no return type └─"test/test_expect_test.ml":1145:50-1145:70 6 |}] + +let%expect_test "%debug_show PrintBox to stdout records" = + let module Debug_runtime = (val Minidebug_runtime.debug ~values_first_mode:false ()) in + let%debug_show bar { first : int; second : int } : int = + let { first : int = a; second : int = b } = { first; second = second + 3 } in + let y : int = a + 1 in + (b - 3) * y + in + let () = print_endline @@ Int.to_string @@ bar { first = 7; second = 42 } in + let baz { first : int; second : int } : int = + let { first : int; second : int } = { first = first + 1; second = second + 3 } in + (first * first) + second + in + let () = print_endline @@ Int.to_string @@ baz { first = 7; second = 42 } in + (* With [~values_first_mode:true], [second] would become a sub-header + while its sibling field [first] would remain at the bottom. *) + [%expect + {| + BEGIN DEBUG SESSION + "test/test_expect_test.ml":1170:21-1173:15: bar + ├─first = 7 + ├─second = 42 + ├─"test/test_expect_test.ml":1171:6: {first=a; second=b} + │ ├─a = 7 + │ └─b = 45 + ├─"test/test_expect_test.ml":1172:6: y + │ └─y = 8 + └─bar = 336 + 336 + "test/test_expect_test.ml":1176:10-1178:28: baz + ├─first = 7 + ├─second = 42 + ├─"test/test_expect_test.ml":1177:8: {first; second} + │ ├─first = 8 + │ └─second = 45 + └─baz = 109 + 109 |}] + +let%expect_test "%debug_show PrintBox to stdout tuples" = + let module Debug_runtime = (val Minidebug_runtime.debug ~values_first_mode:false ()) in + let%debug_show bar ((first : int), (second : int)) : int = + let y : int = first + 1 in + second * y + in + let () = print_endline @@ Int.to_string @@ bar (7, 42) in + let baz ((first, second) : int * int) : int * int = + let (y, z) : int * int = (first + 1, 3) in + let (a : int), (b : int) = (first + 1, second + 3) in + ((second * y) + z, (a * a) + b) + in + let r1, r2 = (baz (7, 42) : int * int) in + let () = print_endline @@ Int.to_string r1 in + let () = print_endline @@ Int.to_string r2 in + (* With [~values_first_mode:true], only [r2] would move to the header + for the result of [baz]. *) + [%expect + {| + BEGIN DEBUG SESSION + "test/test_expect_test.ml":1207:21-1209:14: bar + ├─first = 7 + ├─second = 42 + ├─"test/test_expect_test.ml":1208:8: y + │ └─y = 8 + └─bar = 336 + 336 + "test/test_expect_test.ml":1217:6: (r1, r2) + ├─"test/test_expect_test.ml":1212:10-1215:35: baz + │ ├─first = 7 + │ ├─second = 42 + │ ├─"test/test_expect_test.ml":1213:8: (y, z) + │ │ ├─y = 8 + │ │ └─z = 3 + │ ├─"test/test_expect_test.ml":1214:8: (a, b) + │ │ ├─a = 8 + │ │ └─b = 45 + │ └─baz = (339, 109) + ├─r1 = 339 + └─r2 = 109 + 339 + 109 |}]