Fix printing of optional record fields in pattern matching errors

Author: cknitt

compiler/common/pattern_printer.ml

@@ -1,9 +1,55 @@
 open Types
 open Typedtree
 open Parsetree
+open Asttypes
 
 let mkpat desc = Ast_helper.Pat.mk desc
 
+let is_generated_optional_constructor (lid : Longident.t Location.loc) =
+  match lid.txt with
+  | Longident.Lident name ->
+    String.length name >= 2 && name.[0] = '#' && name.[1] = '$'
+  | _ -> false
+
+(* Optional fields become “option-of-option” internally: the outer layer is
+   added by the compiler to track presence, while the inner layer is the user’s
+   payload. When printing counterexamples we only need to know which of these
+   situations we saw. *)
+type optional_field_state =
+  | Field_normal (* Regular user patterns: `{b: Some(_)}`, `{b}`, `_`, etc. *)
+  | Field_missing
+    (* The outer constructor was the synthetic `#$None…`, i.e. the field was
+         not provided at all. This is what should print as `{b: ?None}`. *)
+  | Field_present_none
+(* The outer constructor was the synthetic `#$Some…` but its payload was
+         still the synthetic `None`. That means the field exists but the user’s
+         inner option is `None`, so we should print `{b: None}`. *)
+
+(* Optional record fields are lowered into an extra option layer; we re-infer
+   whether we’re looking at a missing field vs. a present-but-`None` value so
+   we can render useful surface syntax in error messages. *)
+let[@warning "-4"] rec classify_optional_field_state pat =
+  match pat.pat_desc with
+  | Tpat_construct (lid, cstr, [])
+    when is_generated_optional_constructor lid && cstr.cstr_name = "None" ->
+    Field_missing
+  | Tpat_construct (lid, cstr, [inner])
+    when is_generated_optional_constructor lid && cstr.cstr_name = "Some" -> (
+    match classify_optional_field_state inner with
+    | Field_missing | Field_present_none -> Field_present_none
+    | Field_normal -> Field_normal)
+  | _ -> Field_normal
+
+let none_pattern =
+  mkpat (Ppat_construct (mknoloc (Longident.Lident "None"), None))
+
+let[@warning "-4"] strip_synthetic_some pat =
+  match pat.pat_desc with
+  | Tpat_construct (lid, cstr, [inner])
+    when is_generated_optional_constructor lid && cstr.cstr_name = "Some" ->
+    inner
+  | _ -> pat
+
 let untype typed =
   let rec loop pat =
     match pat.pat_desc with
@@ -30,12 +76,26 @@ let untype typed =
       let arg = Option.map loop p_opt in
       mkpat (Ppat_variant (label, arg))
     | Tpat_record (subpatterns, closed_flag) ->
-      let fields =
-        List.map
-          (fun (_, lbl, p, opt) ->
-            {lid = mknoloc (Longident.Lident lbl.lbl_name); x = loop p; opt})
-          subpatterns
+      let fields, saw_optional_rewrite =
+        List.fold_right
+          (fun (_, lbl, p, opt) (fields, saw_optional_rewrite) ->
+            let state =
+              if lbl.lbl_optional then classify_optional_field_state p
+              else Field_normal
+            in
+            let opt, par_pat, rewrote_optional =
+              match state with
+              | Field_missing -> (true, none_pattern, true)
+              | Field_present_none -> (opt, loop (strip_synthetic_some p), true)
+              | Field_normal -> (opt, loop p, false)
+            in
+            let field =
+              {lid = mknoloc (Longident.Lident lbl.lbl_name); x = par_pat; opt}
+            in
+            (field :: fields, saw_optional_rewrite || rewrote_optional))
+          subpatterns ([], false)
       in
+      let closed_flag = if saw_optional_rewrite then Closed else closed_flag in
       mkpat (Ppat_record (fields, closed_flag))
     | Tpat_array lst -> mkpat (Ppat_array (List.map loop lst))
   in

tests/build_tests/super_errors/expected/optional_record_field_missing_case.res.expected

@@ -0,0 +1,14 @@
+
+  Warning number 8
+  /.../fixtures/optional_record_field_missing_case.res:5:9-8:1
+
+  3 │ let a: t = Obj.magic()
+  4 │ 
+  5 │ let _ = switch a {
+  6 │ | {b: None} => ()
+  7 │ | {b: Some(_)} => ()
+  8 │ }
+  9 │ 
+
+  You forgot to handle a possible case here, for example: 
+  | {b: ?None}

tests/build_tests/super_errors/expected/optional_record_field_missing_case_inline.res.expected

@@ -0,0 +1,14 @@
+
+  Warning number 8
+  /.../fixtures/optional_record_field_missing_case_inline.res:5:9-8:1
+
+  3 │ let v: t = Obj.magic()
+  4 │ 
+  5 │ let _ = switch v {
+  6 │ | A({b: None}) => ()
+  7 │ | A({b: Some(_)}) => ()
+  8 │ }
+  9 │ 
+
+  You forgot to handle a possible case here, for example: 
+  | A({b: ?None})

tests/build_tests/super_errors/expected/optional_record_field_missing_cases_nested.res.expected

@@ -0,0 +1,13 @@
+
+  Warning number 8
+  /.../fixtures/optional_record_field_missing_cases_nested.res:5:9-7:1
+
+  3 │ let a: t = Obj.magic()
+  4 │ 
+  5 │ let _ = switch a {
+  6 │ | {b: Some(Some(_))} => ()
+  7 │ }
+  8 │ 
+
+  You forgot to handle a possible case here, for example: 
+  | {b: Some(None)} | {b: None} | {b: ?None}

tests/build_tests/super_errors/fixtures/optional_record_field_missing_case.res

@@ -0,0 +1,8 @@
+type t = {b?: option<int>}
+
+let a: t = Obj.magic()
+
+let _ = switch a {
+| {b: None} => ()
+| {b: Some(_)} => ()
+}

tests/build_tests/super_errors/fixtures/optional_record_field_missing_case_inline.res

@@ -0,0 +1,8 @@
+type t = A({b?: option<int>})
+
+let v: t = Obj.magic()
+
+let _ = switch v {
+| A({b: None}) => ()
+| A({b: Some(_)}) => ()
+}

tests/build_tests/super_errors/fixtures/optional_record_field_missing_cases_nested.res

@@ -0,0 +1,7 @@
+type t = {b?: option<option<int>>}
+
+let a: t = Obj.magic()
+
+let _ = switch a {
+| {b: Some(Some(_))} => ()
+}