Fixes #9, yay! Tuple and record patterns without aliases

Unfortunately, `value_first_mode:true` doesn't give as nice results (yet).

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

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

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 |}]