flambda-backend: Fix programmatically enabling and disabling the same layouts extension (#1446)

* Add test case for enabling + disabling the same layouts extension

* Fix behavior of enabling and disabling the same layouts extension

Author: antalsz

testsuite/tests/language-extensions/language_extensions.ml

@@ -60,19 +60,37 @@ let try_disallowing_extensions name =
 
 type goal = Fail | Succeed
 
+let with_goal goal ~name ~what test = match goal with
+  | Fail    -> should_fail    name      test
+  | Succeed -> should_succeed name what test
+
+let with_two_layouts goal first second ~enabled =
+  let verb ending =
+    "enabl" ^ ending ^ (if enabled then "" else " and disabl" ^ ending)
+  in
+  let comparison, plural =
+    if first = second then "the same", "" else "two different", "s"
+  in
+  let description ending =
+    verb ending ^ " " ^ comparison ^ " layouts extension" ^ plural
+  in
+  Language_extension.with_enabled (Layouts first) (fun () ->
+    with_goal goal
+      ~name:(description "e")
+      ~what:(description "ing")
+      (fun () ->
+         Language_extension.with_set (Layouts second) ~enabled (fun () -> ())))
+
 let when_disallowed goal f_str f =
   let can_or_can't = match goal with
     | Fail    -> "can't"
     | Succeed -> "can"
   in
   let f_code = "[" ^ f_str ^ "]" in
-  let name =
-    can_or_can't ^ " call " ^ f_code ^ " when extensions are disallowed"
-  in
-  let action () = f extension in
-  match goal with
-  | Fail    -> should_fail    name                                   action
-  | Succeed -> should_succeed name ("redundantly calling " ^ f_code) action
+  with_goal goal
+    ~name:(can_or_can't ^ " call " ^ f_code ^ " when extensions are disallowed")
+    ~what:("redundantly calling " ^ f_code)
+    (fun () -> f extension)
 ;;
 
 let lift_with with_fn extension = with_fn extension Fun.id;;
@@ -147,16 +165,13 @@ Language_extension.with_set extension ~enabled:false (fun () ->
 Language_extension.with_set extension ~enabled:true (fun () ->
   typecheck_with_extension "disabled locally via [with_set] and also globally");
 
-(* Test that we only allow you to pass one layouts extension flag *)
-should_fail "Enable two layouts"
-  (fun () ->
-     Language_extension.(enable (Layouts Alpha));
-     Language_extension.(enable (Layouts Beta)));
+(* Test that we only allow you to pass one distinct layouts extension flag*)
+
+with_two_layouts Succeed Alpha Alpha ~enabled:false;
+
+with_two_layouts Fail    Alpha Beta  ~enabled:false;
 
-should_fail "Enable and disable layouts"
-  (fun () ->
-     Language_extension.(enable (Layouts Alpha));
-     Language_extension.(disable (Layouts Beta)));
+with_two_layouts Fail    Alpha Beta  ~enabled:true;
 
 (* Test disallowing extensions *)
 

testsuite/tests/language-extensions/reference.txt

@@ -52,12 +52,15 @@ Successfully typechecked "[x for x = 1 to 10]"
 # "comprehensions" extension disabled locally via [with_set] and also globally [comprehensions enabled]:
 Successfully typechecked "[x for x = 1 to 10]"
 
-# Enable two layouts [comprehensions enabled]:
-Failed as expected: Invalid extensions: Please enable at most one of 'layouts', 'layouts_beta', and 'layouts_alpha'.
+# enable and disable the same layouts extension [comprehensions enabled]:
+Succeeded at enabling and disabling the same layouts extension
 
-# Enable and disable layouts [comprehensions enabled]:
+# enable and disable two different layouts extensions [comprehensions enabled]:
 Failed as expected: Cannot disable extension layouts_beta because extension layouts_alpha is enabled. Please enable or disable at most one of the layouts extensions.
 
+# enable two different layouts extensions [comprehensions enabled]:
+Failed as expected: Invalid extensions: Please enable at most one of 'layouts', 'layouts_beta', and 'layouts_alpha'.
+
 # can disallow extensions while extensions are enabled [comprehensions disabled]:
 Succeeded at disallowing all extensions
 

utils/language_extension.ml

@@ -1,5 +1,7 @@
 type maturity = Stable | Beta | Alpha
 
+let equal_maturity (a : maturity) (b : maturity) = (a = b)
+
 type t =
   | Comprehensions
   | Local
@@ -125,7 +127,7 @@ let check_conflicts t1 =
      'layouts_beta', and 'layouts_alpha'."
   in
   let c = List.find_map (fun t2 ->
-    if t1 = t2 then Some Duplicate else
+    if equal t1 t2 then Some Duplicate else
       match t1, t2 with
       | Layouts _, Layouts _ -> Some (Incompatible layouts_err)
       | _, _ -> None)
@@ -149,12 +151,13 @@ let set extn ~enabled =
     extensions :=
       List.filter (fun extn' ->
         match extn, extn' with
-        | Layouts _, Layouts _ ->
-          raise (Arg.Bad(Printf.sprintf
-             "Cannot disable extension %s because extension %s is enabled. \
-              Please enable or disable at most one of the layouts extensions."
-             (to_string extn) (to_string extn')))
-        | _, _ -> not (equal extn extn'))
+        | Layouts m1, Layouts m2 when not (equal_maturity m1 m2) ->
+            raise (Arg.Bad(Printf.sprintf
+              "Cannot disable extension %s because extension %s is enabled. \
+               Please enable or disable at most one of the layouts extensions."
+              (to_string extn) (to_string extn')))
+        | _, _ ->
+            not (equal extn extn'))
         !extensions
 
 let enable  = set ~enabled:true