move the logic of legacy mode to printtyp.ml

Author: riaqn

ocaml/typing/oprint.ml

@@ -338,14 +338,17 @@ let pr_var_jkinds =
   disallowed in parsing of this file, but non-legacy modes might still pop
   up. For example, the current file might cite values from other files that
   mention non-legacy modes *)
-let print_out_legacy_axis f ppf = function
-  | None -> ()
-  | Some m -> Format.fprintf ppf "%a_ " f m
+let print_out_mode ppf = function
+  | Omd_local -> fprintf ppf "local_"
+  | Omd_unique -> fprintf ppf "unique_"
+  | Omd_once -> fprintf ppf "once_"
+
+let print_out_mode_space ppf m =
+  print_out_mode ppf m;
+  pp_print_space ppf ()
 
-let print_out_modes ppf (m : Mode.Alloc.Const.Option.t) =
-  print_out_legacy_axis Mode.Locality.Const.print ppf m.locality;
-  print_out_legacy_axis Mode.Linearity.Const.print ppf m.linearity;
-  print_out_legacy_axis Mode.Uniqueness.Const.print ppf m.uniqueness
+let print_out_modes ppf l =
+  pp_print_list print_out_mode_space ppf l
 
 (* Labeled tuples with the first element labeled sometimes require parens. *)
 let is_initially_labeled_tuple ty =
@@ -377,12 +380,16 @@ let rec print_out_type_0 ppf =
    - Or, there is at least one mode to print.
  *)
 and print_out_type_mode ~arg mode ppf ty =
-  let mode = Format.asprintf "%a" print_out_modes mode in
+  let has_modes =
+    match mode with
+    | [] -> false
+    | _ -> true
+  in
   let parens =
     is_initially_labeled_tuple ty
-    && (arg || String.length mode > 0)
+    && (arg || has_modes)
   in
-  pp_print_string ppf mode;
+  print_out_modes ppf mode;
   if parens then
     pp_print_char ppf '(';
   print_out_type_2 ppf ty;

ocaml/typing/outcometree.mli

@@ -84,14 +84,19 @@ type arg_label =
   | Optional of string
   | Position of string
 
-type out_arg_mode = Mode.Alloc.Const.Option.t
+type out_mode =
+  | Omd_local
+  | Omd_unique
+  | Omd_once
+
+type out_arg_mode = out_mode list
 
 type out_ret_mode =
-  | Orm_not_arrow of Mode.Alloc.Const.Option.t
+  | Orm_not_arrow of out_mode list
   (** The ret type is not arrow, with modes annotating. *)
   | Orm_no_parens
   (** The ret type is arrow, and no need to print parens around the arrow *)
-  | Orm_parens of Mode.Alloc.Const.Option.t
+  | Orm_parens of out_mode list
   (** The ret type is arrow, and need to print parens around the arrow, with
       modes annotating. *)
 

ocaml/typing/printtyp.ml

@@ -1257,6 +1257,18 @@ let outcome_label : Types.arg_label -> Outcometree.arg_label = function
   | Optional l -> Optional l
   | Position l -> Position l
 
+let tree_of_mode mode l =
+  match mode with
+  | None -> []
+  (* should never raise *)
+  | Some x -> [List.assoc x l]
+
+let tree_of_modes modes =
+  let diff = Mode.Alloc.Const.diff modes Mode.Alloc.Const.legacy in
+  tree_of_mode diff.locality [Mode.Locality.Const.Local, Omd_local] @
+  tree_of_mode diff.linearity [Mode.Linearity.Const.Once, Omd_once] @
+  tree_of_mode diff.uniqueness [Mode.Uniqueness.Const.Unique, Omd_unique]
+
 (* [alloc_mode] is only used if [ty] is arrow-shaped. *)
 let rec tree_of_typexp mode alloc_mode ty =
   let px = proxy ty in
@@ -1294,7 +1306,7 @@ let rec tree_of_typexp mode alloc_mode ty =
         in
         let acc_mode = curry_mode alloc_mode am in
         let (rm, t2) = tree_of_ret_typ mode acc_mode (mret, ty2) in
-        Otyp_arrow (lab, Alloc.Const.diff am Alloc.Const.legacy, t1, rm, t2)
+        Otyp_arrow (lab, tree_of_modes am, t1, rm, t2)
     | Ttuple labeled_tyl ->
         Otyp_tuple (tree_of_labeled_typlist mode labeled_tyl)
     | Tconstr(p, tyl, _abbrev) ->
@@ -1436,12 +1448,12 @@ and tree_of_ret_typ mode acc_mode (m, ty) =
         axes and we adopt a similar logic to the [marg] above. *)
         let m = Alloc.zap_to_legacy m in
         let ty = tree_of_typexp mode m ty in
-        (Orm_parens (Alloc.Const.diff m Alloc.Const.legacy), ty)
+        (Orm_parens (tree_of_modes m), ty)
       end
   | _ ->
     let m = Alloc.zap_to_legacy m in
     let ty = tree_of_typexp mode m ty in
-    (Orm_not_arrow (Alloc.Const.diff m Alloc.Const.legacy), ty)
+    (Orm_not_arrow (tree_of_modes m), ty)
 
 and tree_of_typobject mode fi nm =
   begin match nm with