diff --git a/CHANGELOG.md b/CHANGELOG.md index 8d4e694..510744a 100644 --- a/CHANGELOG.md +++ b/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 diff --git a/README.md b/README.md index 9c3c606..14c5fd0 100644 --- a/README.md +++ b/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 diff --git a/ppx_minidebug.ml b/ppx_minidebug.ml index 9637526..09cf6a2 100644 --- a/ppx_minidebug.ml +++ b/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); _ } -> diff --git a/test/test_expect_test.ml b/test/test_expect_test.ml index f05e4c6..ce6ba06 100644 --- a/test/test_expect_test.ml +++ b/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 + {| |}]