Broken: Handle all kinds of patterns, yay!

The test fails to compile, wrong source transformation.

CHANGELOG.md

@@ -5,13 +5,15 @@
 - PrintBox Markdown backend.
 - Optionally, log to multiple files, opening a new file once a file size threshold is exceeded.
 - Continuous Integration tests.
+- Fixes #9: handle tuple and record patterns.
+- Handle variants patterns and more.
+- Log bindings in `match` and `function` patterns, but only when in a `%track_` scope.
 
 ### Changed
 
 - 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.
-- Fixes #9: handle tuple and record patterns.
 - Exported `PrintBox_runtime` configuration for better flexibility (in-flight configuration changes).
 
 ## [0.9.0] -- 2024-01-18

README.md

@@ -416,7 +416,11 @@ Here is a probably incomplete list of the restrictions:
 - When types for a (sub) pattern are specified in multiple places, they are not combined. The type that is closer to the (sub) pattern is inspected, even if inspecting a corresponding type in another place would be better.
 - When faced with a binding of a form: `let pattern = (expression : type_)`, we make use of `type_`, but we ignore all types nested inside `expression`, even if we decompose `pattern`.
   - For example, `let%track_sexp (x, y) = ((5, 3) : int * int)` works -- logs both `x` and `y`. Also work: `let%track_sexp ((x, y) : int * int) = (5, 3)` and `let%track_sexp ((x : int), (y : int)) = (5, 3)`. But `let%track_sexp (x, y) = ((5 : int), (3 : int))` will not log anything!
-
+- We ignore record and variant datatypes when processing record and variant constructor cases. That's because there is no generic(*) way to extract the types of the arguments.
+  - We do handle tuple types and the builtin array type (they are not records or variants).
+  - Hard-coded special cases: we do handle the option type and the list type.
+    - For example, this works: `let%track_sexp { first : int; second : int } = { first = 3; second =7 }` -- but compare with the tuple examples above, the alternatives provided above would not work for records.
+    - (*) Although polymorphic variant types can be provided inline, we decided it's not worth the effort supporting them.
 
 ## VS Code suggestions
 

ppx_minidebug.ml

@@ -25,13 +25,36 @@ let rec pat2descr ~default pat =
           fields
       in
       { txt = "{" ^ String.concat "; " dscrs ^ "}"; loc }
-  | _ -> { txt = default; loc }
+  | Ppat_construct (lid, None) -> { txt = last_ident lid.txt; loc }
+  | Ppat_construct (lid, Some (_abs_tys, pat)) ->
+      let dscr = pat2descr ~default pat in
+      { txt = last_ident lid.txt ^ " " ^ dscr.txt; loc }
+  | Ppat_variant (lid, None) -> { txt = lid; loc }
+  | Ppat_variant (lid, Some pat) ->
+      let dscr = pat2descr ~default pat in
+      { txt = lid ^ " " ^ dscr.txt; loc }
+  | Ppat_array tups ->
+      let dscrs = List.map (fun p -> (pat2descr ~default:"_" p).txt) tups in
+      { txt = "[|" ^ String.concat ", " dscrs ^ "|]"; loc }
+  | Ppat_or (pat1, pat2) ->
+      let dscr1 = pat2descr ~default pat1 in
+      let dscr2 = pat2descr ~default pat2 in
+      { txt = dscr1.txt ^ "|" ^ dscr2.txt; loc }
+  | Ppat_exception pat ->
+      let dscr = pat2descr ~default pat in
+      { txt = "exception " ^ dscr.txt; loc }
+  | Ppat_lazy pat ->
+      let dscr = pat2descr ~default pat in
+      { txt = "lazy " ^ dscr.txt; loc }
+  | Ppat_open (_, pat) -> pat2descr ~default pat
+  | Ppat_type _ | Ppat_extension _ | Ppat_unpack _ | Ppat_any | Ppat_constant _
+  | Ppat_interval _ ->
+      { txt = default; loc }
 
 let rec pat2expr pat =
   let loc = pat.ppat_loc in
   match pat.ppat_desc with
-  | Ppat_constraint (pat', typ) ->
-      A.pexp_constraint ~loc (pat2expr pat') typ
+  | Ppat_constraint (pat', typ) -> A.pexp_constraint ~loc (pat2expr pat') typ
   | Ppat_alias (_, ident) | Ppat_var ident ->
       A.pexp_ident ~loc { ident with txt = Lident ident.txt }
   | _ ->
@@ -171,15 +194,16 @@ let rec expand_fun body = function
 
 let bound_patterns ~alt_typ pat =
   let rec loop ~alt_typ pat =
+    let loc = pat.ppat_loc in
     match (alt_typ, pat) with
     | ( _,
         [%pat?
           ([%p? { ppat_desc = Ppat_var descr_loc | Ppat_alias (_, descr_loc); _ } as pat] :
             [%t? typ])] ) ->
-        (A.ppat_var ~loc:pat.ppat_loc descr_loc, [ (descr_loc, pat, typ) ])
+        (A.ppat_var ~loc descr_loc, [ (descr_loc, pat, typ) ])
     | 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) ])
+        (A.ppat_var ~loc descr_loc, [ (descr_loc, pat, typ) ])
     | ( _,
         [%pat?
           ([%p? { ppat_desc = Ppat_tuple pats; ppat_loc; _ }] :
@@ -206,7 +230,71 @@ let bound_patterns ~alt_typ pat =
         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, [])
+        (* FIXME: special-case some builtin types: option, list. *)
+    | _, { ppat_desc = Ppat_construct (_lid, None); _ } -> (pat, [])
+    | _, { ppat_desc = Ppat_construct (lid, Some (_abs_tys, pat)); _ } ->
+        let pat, bindings = loop ~alt_typ:None pat in
+        (A.ppat_construct ~loc lid (Some pat), bindings)
+    | _, { ppat_desc = Ppat_variant (_lid, None); _ } -> (pat, [])
+    | _, { ppat_desc = Ppat_variant (lid, Some pat); _ } ->
+        let pat, bindings = loop ~alt_typ:None pat in
+        (A.ppat_variant ~loc lid (Some pat), bindings)
+    | _, [%pat? ([%p? { ppat_desc = Ppat_array pats; ppat_loc; _ }] : [%t? typ] array)] ->
+        (* TODO: ideally we should combine with the alt_typ information if present. *)
+        let pats, bindings =
+          List.split @@ List.map (fun pat -> loop ~alt_typ:(Some typ) pat) pats
+        in
+        (A.ppat_array ~loc:ppat_loc pats, List.concat bindings)
+    | Some [%type: [%t? typ] array], { ppat_desc = Ppat_array pats; ppat_loc; _ } ->
+        let pats, bindings =
+          List.split @@ List.map (fun pat -> loop ~alt_typ:(Some typ) pat) pats
+        in
+        (A.ppat_array ~loc:ppat_loc pats, List.concat bindings)
+    | _, { ppat_desc = Ppat_array pats; ppat_loc; _ } ->
+        let pats, bindings =
+          List.split @@ List.map (fun pat -> loop ~alt_typ:None pat) pats
+        in
+        (A.ppat_array ~loc:ppat_loc pats, List.concat bindings)
+    | _, { ppat_desc = Ppat_or (pat1, pat2); _ } ->
+        let pat1, binds1 = loop ~alt_typ pat1 in
+        let binds1 =
+          List.map (fun (({ txt = descr; _ }, _, _) as b) -> (descr, b)) binds1
+        in
+        let pat2, binds2 = loop ~alt_typ pat2 in
+        let binds2 =
+          List.map (fun (({ txt = descr; _ }, _, _) as b) -> (descr, b)) binds2
+        in
+        let bindings =
+          List.sort_uniq (fun (k1, _) (k2, _) -> String.compare k1 k2) @@ binds1 @ binds2
+        in
+        (A.ppat_or ~loc pat1 pat2, List.map snd bindings)
+    | _, { ppat_desc = Ppat_exception pat; _ } ->
+        let pat, bindings = loop ~alt_typ:None pat in
+        (A.ppat_exception ~loc pat, bindings)
+    | Some [%type: [%t? typ] Lazy.t], { ppat_desc = Ppat_lazy pat; _ } ->
+        let pat, bindings = loop ~alt_typ:(Some typ) pat in
+        (A.ppat_lazy ~loc pat, bindings)
+    | _, [%pat? ([%p? { ppat_desc = Ppat_lazy pat; _ }] : [%t? typ] Lazy.t)] ->
+        let pat, bindings = loop ~alt_typ:(Some typ) pat in
+        (A.ppat_lazy ~loc pat, bindings)
+    | _, { ppat_desc = Ppat_lazy pat; _ } ->
+        let pat, bindings = loop ~alt_typ:None pat in
+        (A.ppat_lazy ~loc pat, bindings)
+    | _, { ppat_desc = Ppat_open (m, pat); _ } ->
+        let pat, bindings = loop ~alt_typ pat in
+        (A.ppat_open ~loc m pat, bindings)
+    | _, [%pat? ([%p? pat] : [%t? typ])] -> loop ~alt_typ:(Some typ) pat
+    | None, { ppat_desc = Ppat_var _ | Ppat_alias (_, _); _ } ->
+        (* Insufficient type information. *)
+        (pat, [])
+    | ( _,
+        {
+          ppat_desc =
+            ( Ppat_type _ | Ppat_extension _ | Ppat_unpack _ | Ppat_any | Ppat_constant _
+            | Ppat_interval _ );
+          _;
+        } ) ->
+        (A.ppat_any ~loc, [])
   in
   let bind_pat, bound = loop ~alt_typ pat in
   let loc = pat.ppat_loc in
@@ -404,7 +492,12 @@ let traverse =
                     Debug_runtime.close_log ();
                     raise e]
             in
-            { pc_lhs; pc_guard; pc_rhs })
+            try
+              let vb =
+                debug_binding callback @@ A.value_binding ~loc ~pat:pc_lhs ~expr:pc_rhs
+              in
+              { pc_lhs = vb.pvb_pat; pc_guard; pc_rhs = vb.pvb_expr }
+            with Not_transforming -> { pc_lhs; pc_guard; pc_rhs })
       in
       match e with
       | { pexp_desc = Pexp_let (rec_flag, bindings, body); _ } ->

test/test_expect_test.ml

@@ -1326,3 +1326,25 @@ let%expect_test "%debug_show PrintBox to stdout tuples values_first_mode" =
           └─b = 45
     339
     109 |}]
+
+type 'a irrefutable = Zero of 'a [@@deriving show]
+type ('a, 'b) left_right = Left of 'a | Right of 'b [@@deriving show]
+type ('a, 'b, 'c) one_two_three = One of 'a | Two of 'b | Three of 'c [@@deriving show]
+
+let%expect_test "%debug_show PrintBox to stdout variants values_first_mode" =
+  let module Debug_runtime = (val Minidebug_runtime.debug ~values_first_mode:true ()) in
+  let%track_show bar (Zero (x : int)) : int =
+    let y = (x + 1 : int) in
+    2 * y
+  in
+  let () = print_endline @@ Int.to_string @@ bar (Zero 7) in
+  let baz : 'a -> int = function
+    | Left (x : int) -> x + 1
+    | Right (Two (y : int)) -> y * 2
+    | _ -> 3
+  in
+  let () = print_endline @@ Int.to_string @@ baz (Left 4) in
+  let () = print_endline @@ Int.to_string @@ baz (Right (Two 3)) in
+  let () = print_endline @@ Int.to_string @@ baz (Right (Three 0)) in
+  [%expect
+    {| |}]