Multiway match typechecking and translation for pattern guards (#2)

* multiway typechecking and translation * update jane test output * self-review: format and style in translcore * more translcore/typedtree cleanup * expose value `is_guarded_rhs` * fix typedtree printer * make discussed changes to ocamldoc * format: remove unnecessary parens in pattern Co-authored-by: Nick Roberts <[email protected]> * improve parmatch variable naming * explain [exp_attributes] and [exp_extra] weirdness * improve translcore [event_function*] naming * inlined transl_body in transl_rhs * rename pats_exp... to use "rhs" naming * added test for guarded value/exception or-patterns * address ocamldoc CRs --------- Co-authored-by: Nick Roberts <[email protected]>
rajgodse · Aug 2, 2023 · 278f127 · 278f127
1 parent 4e22f63
commit 278f127
Show file tree

Hide file tree

Showing 17 changed files with 450 additions and 404 deletions.
diff --git a/ocaml/lambda/translcore.ml b/ocaml/lambda/translcore.ml
diff --git a/ocaml/ocamldoc/odoc_ast.ml b/ocaml/ocamldoc/odoc_ast.ml
@@ -301,31 +301,35 @@ module Analyser =
          (* we look if the name of the parameter we just add is "*opt*", which means
             that there is a let param_name = ... in ... just right now *)
           let (p, next_exp) =
-            match parameter with
-              Simple_name { sn_name = "*opt*" } ->
-                (
-                 (
-                  match func_body.exp_desc with
-                    Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _, _) };
-                                            vb_expr=exp} :: _, func_body2) ->
-                      let name = Name.from_ident id in
-                      let new_param = Simple_name
-                          { sn_name = name ;
-                            sn_text = Odoc_parameter.desc_from_info_opt current_comment_opt name ;
-                            sn_type = Odoc_env.subst_type env exp.exp_type
-                          }
-                      in
-                      (new_param, func_body2)
-                  | _ ->
-                      (parameter, func_body)
-                 )
-                )
-            | _ ->
-                (parameter, func_body)
+            match func_body with
+            | Pattern_guarded_rhs _ -> parameter, None
+            | Simple_rhs func_body
+            | Boolean_guarded_rhs { bg_rhs = func_body; _ } ->
+                match parameter with
+                  Simple_name { sn_name = "*opt*" } ->
+                    (
+                     (
+                      match func_body.exp_desc with
+                        Typedtree.Texp_let (_, {vb_pat={pat_desc = Typedtree.Tpat_var (id, _, _) };
+                                                vb_expr=exp} :: _, func_body2) ->
+                          let name = Name.from_ident id in
+                          let new_param = Simple_name
+                              { sn_name = name ;
+                                sn_text = Odoc_parameter.desc_from_info_opt current_comment_opt name ;
+                                sn_type = Odoc_env.subst_type env exp.exp_type
+                              }
+                          in
+                          (new_param, Some func_body2)
+                      | _ ->
+                          (parameter, Some func_body)
+                      )
+                     )
+                | _ ->
+                    parameter, Some func_body
           in
          (* continue if the body is still a function *)
-          match next_exp.exp_desc with
-            Texp_function { cases = pat_exp_list ; _ } ->
+          match next_exp with
+          | Some { exp_desc = Texp_function { cases = pat_exp_list ; _ } } ->
               p :: (tt_analyse_function_parameters env current_comment_opt pat_exp_list)
           | _ ->
               (* something else ; no more parameter *)
@@ -445,8 +449,8 @@ module Analyser =
                          sn_type = Odoc_env.subst_type env pattern_param.Typedtree.pat_type }
                    in
                    [ new_param ]
-
-               | {c_lhs=pattern_param; c_rhs=body} :: [] ->
+               | {c_rhs=Pattern_guarded_rhs _} :: [] -> []
+               | {c_lhs=pattern_param; c_rhs=Simple_rhs body | Boolean_guarded_rhs {bg_rhs = body}} :: [] ->
                    (* if this is the first call to the function, this is the first parameter and we skip it *)
                    if not first then
                      (

diff --git a/ocaml/testsuite/tests/pattern-guards/jane_test.ml b/ocaml/testsuite/tests/pattern-guards/jane_test.ml
@@ -33,7 +33,5 @@ let pattern_guard_doesnt_return_local f x =
   | _ -> 3
 ;;
 [%%expect{|
->> Fatal error: typechecking for multicase pattern guards unimplemented
-Uncaught exception: Misc.Fatal_error
-
+val pattern_guard_doesnt_return_local : 'a -> 'b option -> int = <fun>
 |}]
diff --git a/ocaml/testsuite/tests/pattern-guards/test.ml b/ocaml/testsuite/tests/pattern-guards/test.ml
@@ -298,6 +298,19 @@ Line 3, characters 4-32:
 Error: Mixing value and exception patterns under when-guards is not supported.
 |}];;
 
+(* Test rejection of pattern guards on mixed exception/value or-patterns *)
+let reject_guarded_val_exn_orp k =
+  match k () with
+  | Some s | exception Failure s when s match "foo" -> s
+  | _ -> "Not foo"
+;;
+[%%expect{|
+Line 3, characters 4-32:
+3 |   | Some s | exception Failure s when s match "foo" -> s
+        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Mixing value and exception patterns under when-guards is not supported.
+|}];;
+
 module M : sig
   type 'a t
 
@@ -509,52 +522,36 @@ let collatz = function
 ;;
 
 [%%expect{|
->> Fatal error: typechecking for multicase pattern guards unimplemented
-Uncaught exception: Misc.Fatal_error
-
+val nested_singleway :
+  ('a -> 'b option) ->
+  ('b -> 'c option) -> ('c -> 'd option) -> default:'d -> 'a option -> 'd =
+  <fun>
+val collatz : int -> int option = <fun>
 |}];;
 
 nested_singleway collatz collatz collatz ~default:~-1 None;;
 [%%expect{|
-Line 1, characters 0-16:
-1 | nested_singleway collatz collatz collatz ~default:~-1 None;;
-    ^^^^^^^^^^^^^^^^
-Error: Unbound value nested_singleway
+- : int = -1
 |}];;
 nested_singleway collatz collatz collatz ~default:~-1 (Some 1);;
 [%%expect{|
-Line 1, characters 0-16:
-1 | nested_singleway collatz collatz collatz ~default:~-1 (Some 1);;
-    ^^^^^^^^^^^^^^^^
-Error: Unbound value nested_singleway
+- : int = -1
 |}];;
 nested_singleway collatz collatz collatz ~default:~-1 (Some 2);;
 [%%expect{|
-Line 1, characters 0-16:
-1 | nested_singleway collatz collatz collatz ~default:~-1 (Some 2);;
-    ^^^^^^^^^^^^^^^^
-Error: Unbound value nested_singleway
+- : int = -1
 |}];;
 nested_singleway collatz collatz collatz ~default:~-1 (Some 3);;
 [%%expect{|
-Line 1, characters 0-16:
-1 | nested_singleway collatz collatz collatz ~default:~-1 (Some 3);;
-    ^^^^^^^^^^^^^^^^
-Error: Unbound value nested_singleway
+- : int = 16
 |}];;
 nested_singleway collatz collatz collatz ~default:~-1 (Some 4);;
 [%%expect{|
-Line 1, characters 0-16:
-1 | nested_singleway collatz collatz collatz ~default:~-1 (Some 4);;
-    ^^^^^^^^^^^^^^^^
-Error: Unbound value nested_singleway
+- : int = -1
 |}];;
 nested_singleway collatz collatz collatz ~default:~-1 (Some 8);;
 [%%expect{|
-Line 1, characters 0-16:
-1 | nested_singleway collatz collatz collatz ~default:~-1 (Some 8);;
-    ^^^^^^^^^^^^^^^^
-Error: Unbound value nested_singleway
+- : int = 1
 |}];;
 
 let find_multiway ~eq ~flag ~finish ~default = function
@@ -565,9 +562,9 @@ let find_multiway ~eq ~flag ~finish ~default = function
   | _ -> default
 ;;
 [%%expect{|
->> Fatal error: typechecking for multicase pattern guards unimplemented
-Uncaught exception: Misc.Fatal_error
-
+val find_multiway :
+  eq:('a -> 'a -> bool) ->
+  flag:'a -> finish:('a -> 'b) -> default:'b -> 'a list -> 'b = <fun>
 |}];;
 
 let eq n m = (n - m) mod 100 = 0;;
@@ -583,31 +580,19 @@ val default : string = "No match found"
 
 find_multiway ~eq ~flag ~finish ~default [ 10; 20; 110; 100 ];;
 [%%expect{|
-Line 1, characters 0-13:
-1 | find_multiway ~eq ~flag ~finish ~default [ 10; 20; 110; 100 ];;
-    ^^^^^^^^^^^^^
-Error: Unbound value find_multiway
+- : string = "110"
 |}];;
 find_multiway ~eq ~flag ~finish ~default [ 10; 20; 100; 110 ];;
 [%%expect{|
-Line 1, characters 0-13:
-1 | find_multiway ~eq ~flag ~finish ~default [ 10; 20; 100; 110 ];;
-    ^^^^^^^^^^^^^
-Error: Unbound value find_multiway
+- : string = "0"
 |}];;
 find_multiway ~eq ~flag ~finish ~default [ 10; 20; 30; 40 ];;
 [%%expect{|
-Line 1, characters 0-13:
-1 | find_multiway ~eq ~flag ~finish ~default [ 10; 20; 30; 40 ];;
-    ^^^^^^^^^^^^^
-Error: Unbound value find_multiway
+- : string = "No match found"
 |}];;
 find_multiway ~eq ~flag ~finish ~default [ 0; 100 ];;
 [%%expect{|
-Line 1, characters 0-13:
-1 | find_multiway ~eq ~flag ~finish ~default [ 0; 100 ];;
-    ^^^^^^^^^^^^^
-Error: Unbound value find_multiway
+- : string = "0"
 |}];;
 
 let nested_multiway f g h = function
@@ -621,9 +606,9 @@ let nested_multiway f g h = function
   | _ -> "not found"
 ;;
 [%%expect{|
->> Fatal error: typechecking for multicase pattern guards unimplemented
-Uncaught exception: Misc.Fatal_error
-
+val nested_multiway :
+  ('a -> string) ->
+  ('a -> string list) -> ('a -> bool) -> 'a option -> string = <fun>
 |}];;
 
 let f = function
@@ -647,45 +632,27 @@ val h : int -> bool = <fun>
 
 nested_multiway f g h None;;
 [%%expect{|
-Line 1, characters 0-15:
-1 | nested_multiway f g h None;;
-    ^^^^^^^^^^^^^^^
-Error: Unbound value nested_multiway
+- : string = "not found"
 |}];;
 nested_multiway f g h (Some 0);;
 [%%expect{|
-Line 1, characters 0-15:
-1 | nested_multiway f g h (Some 0);;
-    ^^^^^^^^^^^^^^^
-Error: Unbound value nested_multiway
+- : string = "not found"
 |}];;
 nested_multiway f g h (Some 1);;
 [%%expect{|
-Line 1, characters 0-15:
-1 | nested_multiway f g h (Some 1);;
-    ^^^^^^^^^^^^^^^
-Error: Unbound value nested_multiway
+- : string = "foo1"
 |}];;
 nested_multiway f g h (Some 10);;
 [%%expect{|
-Line 1, characters 0-15:
-1 | nested_multiway f g h (Some 10);;
-    ^^^^^^^^^^^^^^^
-Error: Unbound value nested_multiway
+- : string = "bar empty"
 |}];;
 nested_multiway f g h (Some 100);;
 [%%expect{|
-Line 1, characters 0-15:
-1 | nested_multiway f g h (Some 100);;
-    ^^^^^^^^^^^^^^^
-Error: Unbound value nested_multiway
+- : string = "bar singleton one"
 |}];;
 nested_multiway f g h (Some 1000);;
 [%%expect{|
-Line 1, characters 0-15:
-1 | nested_multiway f g h (Some 1000);;
-    ^^^^^^^^^^^^^^^
-Error: Unbound value nested_multiway
+- : string = "not found"
 |}];;
 
 (* Checks that optional arguments with defaults are correclty bound in the

diff --git a/ocaml/typing/cmt2annot.ml b/ocaml/typing/cmt2annot.ml
@@ -43,20 +43,13 @@ let bind_bindings scope bindings =
 
 let bind_cases l =
   List.iter
-    (fun {c_lhs; c_guard; c_rhs} ->
+    (fun {c_lhs; c_rhs} ->
       let loc =
-        let open Location in
-        match c_guard with
-        | None -> c_rhs.exp_loc
-        | Some g ->
-          let gexp =
-            match g with
-            | Predicate pred -> pred
-            | Pattern { pg_scrutinee; pg_pattern; _ } ->
-                bind_variables c_rhs.exp_loc pg_pattern;
-                pg_scrutinee
-              in
-          {c_rhs.exp_loc with loc_start=gexp.exp_loc.loc_start}
+        match c_rhs with
+        | Simple_rhs rhs -> rhs.exp_loc
+        | Boolean_guarded_rhs { bg_guard; bg_rhs } ->
+            { bg_rhs.exp_loc with loc_start = bg_guard.exp_loc.loc_start }
+        | Pattern_guarded_rhs { pg_loc; _ } -> pg_loc
       in
       bind_variables loc c_lhs
     )