Import compiler changes from PR 5398 (#218)

* Backport changes

* Fix spacing

Author: liam923

src/ocaml/typing/printtyp.ml

@@ -1352,7 +1352,7 @@ let outcome_label : Types.arg_label -> Outcometree.arg_label = function
     accordingly. *)
 let tree_of_modalities mut t =
   t
-  |> Typemode.least_modalities_implying mut
+  |> Typemode.least_modalities ~include_implied:false ~mut
   |> Typemode.sort_dedup_modalities
   |> List.map (fun (Atom (ax, m) : Modality.atom) ->
       Format.asprintf "%a" (Modality.Per_axis.print ax) m)

src/ocaml/typing/typemode.ml

@@ -520,7 +520,7 @@ let idx_expected_modalities ~(mut : bool) =
       "Typemode.idx_expected_modalities: mismatch with mutable implied \
        modalities"
 
-let least_modalities_implying mut (t : Modality.Const.t) =
+let least_modalities ~include_implied ~mut (t : Modality.Const.t) =
   let baseline =
     mutable_implied_modalities ~for_mutable_variable:false
       (Types.is_mutable mut)
@@ -534,7 +534,7 @@ let least_modalities_implying mut (t : Modality.Const.t) =
     List.filter_map
       (fun (Modality.Atom (ax, m_implied)) ->
         let m_projected = Modality.Const.proj ax t in
-        if m_projected <> m_implied
+        if m_projected <> m_implied || include_implied
         then Some (Modality.Atom (ax, m_projected))
         else None)
       implied
@@ -545,27 +545,59 @@ let untransl_mod_bounds ?(verbose = false) (bounds : Jkind.Mod_bounds.t) :
     Parsetree.modes =
   let crossing = Jkind.Mod_bounds.crossing bounds in
   let modality = Crossing.to_modality crossing in
+  let least_modalities =
+    least_modalities ~include_implied:verbose ~mut:Immutable modality
+  in
   let modality_annots =
-    least_modalities_implying Types.Immutable modality
-    |> List.map (fun (Atom (ax, m) : Modality.atom) ->
+    List.map
+      (fun (Atom (ax, m) : Modality.atom) ->
         let s = Format.asprintf "%a" (Modality.Per_axis.print ax) m in
         { Location.txt = Parsetree.Mode s; loc = Location.none })
+      least_modalities
   in
-  let nonmodal_annots =
+  (* These mod-bounds are top ones, which are redundant to print. But we include
+     them when printing verbosely. *)
+  let top_modality_annots () =
+    List.filter_map
+      (fun ax ->
+        let (P ax) = Modality.Axis.of_value ax in
+        let included_in_nonverbose =
+          List.exists
+            (fun (Atom (ax2, _) : Modality.atom) ->
+              Modality.Axis.P ax = Modality.Axis.P ax2)
+            least_modalities
+        in
+        match included_in_nonverbose with
+        | true -> None
+        | false ->
+          let s =
+            Format.asprintf "%a"
+              (Modality.Per_axis.print ax)
+              (Modality.Const.proj ax modality)
+          in
+          Some { Location.txt = Parsetree.Mode s; loc = Location.none })
+      Value.Axis.all
+  in
+  let nonmodal_annots, top_nonmodal_annots =
     let open Jkind.Mod_bounds in
-    let mk_annot default print value =
-      if (not verbose) && value = default
-      then None
-      else
-        let s = Format.asprintf "%a" print value in
-        Some { Location.txt = Parsetree.Mode s; loc = Location.none }
+    let mk_annot top print value =
+      let only_when_verbose = value = top in
+      let s = Format.asprintf "%a" print value in
+      ( { Location.txt = Parsetree.Mode s; loc = Location.none },
+        only_when_verbose )
     in
     [ mk_annot Externality.max Externality.print (externality bounds);
       mk_annot Nullability.max Nullability.print (nullability bounds);
       mk_annot Separability.max Separability.print (separability bounds) ]
-    |> List.filter_map Fun.id
+    |> List.partition_map (fun (annot, only_when_verbose) ->
+        match only_when_verbose with false -> Left annot | true -> Right annot)
+  in
+  let verbose_annots =
+    match verbose with
+    | true -> top_modality_annots () @ top_nonmodal_annots
+    | false -> []
   in
-  modality_annots @ nonmodal_annots
+  modality_annots @ nonmodal_annots @ verbose_annots
 
 let sort_dedup_modalities ~warn l =
   let open Modality in

src/ocaml/typing/typemode.mli

@@ -33,8 +33,14 @@ val transl_modalities :
   Parsetree.modalities ->
   modalities
 
-val least_modalities_implying :
-  Types.mutability -> Mode.Modality.Const.t -> Mode.Modality.atom list
+(** Find the minimum modality annots a user must write to express the given
+    modality. If [include_implied] is [false], modalities implied by other
+    written modalities are included, even if not necessary. *)
+val least_modalities :
+  include_implied:bool ->
+  mut:Types.mutability ->
+  Mode.Modality.Const.t ->
+  Mode.Modality.atom list
 
 val sort_dedup_modalities : Mode.Modality.atom list -> Mode.Modality.atom list
 

tests/test-dirs/kind-enclosing/verbosity.t

@@ -14,7 +14,20 @@
   > EOF
   Verbosity 0: immediate
   Verbosity 1: value mod global many stateless immutable external_ non_float
-  Verbosity 2: value mod global many stateless immutable external_ non_null non_float
+  Verbosity 2: value
+    mod global
+        many
+        stateless
+        immutable
+        forkable
+        unyielding
+        aliased
+        portable
+        contended
+        external_
+        non_null
+        non_float
+        static
 
   $ run 1:17 <<EOF
   > type 'a t = 'a option
@@ -27,9 +40,14 @@
         many
         stateless
         immutable
-        internal
+        portable
+        contended
         non_null
         non_float
+        local
+        unique
+        static
+        internal
     with 'a
 
   $ run 2:6 <<EOF
@@ -44,14 +62,78 @@
         many
         stateless
         immutable
-        internal
+        portable
+        contended
         non_null
         non_float
+        local
+        unique
+        static
+        internal
     with int t1
 
   $ run 1:5 <<EOF
   > type t : value mod portable
   > EOF
   Verbosity 0: value mod portable
-  Verbosity 1: value mod portable internal non_null separable
-  Verbosity 2: value mod portable internal non_null separable
+  Verbosity 1: value
+    mod portable
+        non_null
+        separable
+        local
+        unforkable
+        yielding
+        once
+        stateful
+        unique
+        read_write
+        uncontended
+        static
+        internal
+  Verbosity 2: value
+    mod portable
+        non_null
+        separable
+        local
+        unforkable
+        yielding
+        once
+        stateful
+        unique
+        read_write
+        uncontended
+        static
+        internal
+
+  $ run 1:5 <<EOF
+  > type t : value mod stateless
+  > EOF
+  Verbosity 0: value mod stateless
+  Verbosity 1: value
+    mod stateless
+        portable
+        non_null
+        separable
+        local
+        unforkable
+        yielding
+        once
+        unique
+        read_write
+        uncontended
+        static
+        internal
+  Verbosity 2: value
+    mod stateless
+        portable
+        non_null
+        separable
+        local
+        unforkable
+        yielding
+        once
+        unique
+        read_write
+        uncontended
+        static
+        internal