Fix printing of optional record fields in error messages

Author: cknitt

compiler/common/dune

@@ -5,5 +5,5 @@
   (action
    (run %{bin:cppo} %{env:CPPO_FLAGS=} %{input-file})))
  (flags
-  (:standard -w +a-9-40-42))
+  (:standard -w +a-4-9-40-42))
  (libraries syntax))

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_absence =
+  | Not_special (* Regular user patterns: `{b: Some(_)}`, `{b}`, `_`, etc. *)
+  | Missing_field
+    (* The outer constructor was the synthetic `#$None…`, i.e. the field was
+         not provided at all. This is what should print as `{b: ?None}`. *)
+  | Present_missing_value
+(* 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 rec classify_optional_absence pat =
+  match pat.pat_desc with
+  | Tpat_construct (lid, cstr, [])
+    when is_generated_optional_constructor lid && cstr.cstr_name = "None" ->
+    Missing_field
+  | Tpat_construct (lid, cstr, [inner])
+    when is_generated_optional_constructor lid && cstr.cstr_name = "Some" -> (
+    match classify_optional_absence inner with
+    | Missing_field | Present_missing_value -> Present_missing_value
+    | Not_special -> Not_special)
+  | _ -> Not_special
+
+let none_pattern =
+  mkpat (Ppat_construct (mknoloc (Longident.Lident "None"), None))
+
+let 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,32 @@ let untype typed =
       let arg = Option.map loop p_opt in
       mkpat (Ppat_variant (label, arg))
     | Tpat_record (subpatterns, closed_flag) ->
+      let special_case_seen = ref false in
       let fields =
         List.map
           (fun (_, lbl, p, opt) ->
-            {lid = mknoloc (Longident.Lident lbl.lbl_name); x = loop p; opt})
+            let classification =
+              if lbl.lbl_optional then classify_optional_absence p
+              else Not_special
+            in
+            (match classification with
+            | Missing_field | Present_missing_value -> special_case_seen := true
+            | Not_special -> ());
+            let opt =
+              match classification with
+              | Missing_field -> true
+              | Present_missing_value | Not_special -> opt
+            in
+            let par_pat =
+              match classification with
+              | Missing_field -> none_pattern
+              | Present_missing_value -> loop (strip_synthetic_some p)
+              | Not_special -> loop p
+            in
+            {lid = mknoloc (Longident.Lident lbl.lbl_name); x = par_pat; opt})
           subpatterns
       in
+      let closed_flag = if !special_case_seen 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(_))} => ()
+}