Oxcaml: Support for modes

CHANGES.md

@@ -5,6 +5,7 @@
 - Remove requirement for ppx_expect in tests (@jonludlam, #1445)
 - Support for OxCaml modalities (@art-w, #1420)
 - Fix resolving functor through `module type of` (@Leonidas-from-XIV, #1471)
+- Support for OxCaml modes (@art-w, #1454)
 
 # 3.2.1
 

sherlodoc/index/load_doc.ml

@@ -82,21 +82,22 @@ let searchable_type_of_constructor args res =
   | TypeDecl.Constructor.Tuple args -> begin
       match args with
       | _ :: _ :: _ ->
-          TypeExpr.Arrow (None, Tuple (List.map (fun (x, _mods) -> None, x) args), res)
-      | [ (arg, _) ] -> TypeExpr.Arrow (None, arg, res)
+          TypeExpr.Arrow
+            (None, (Tuple (List.map (fun (x, _mods) -> None, x) args), []), (res, []))
+      | [ (arg, _) ] -> TypeExpr.Arrow (None, (arg, []), (res, []))
       | _ -> res
     end
   | TypeDecl.Constructor.Record fields ->
       List.fold_left
         (fun res field ->
            let open TypeDecl.Field in
            let field_name = Odoc_model.Paths.Identifier.name field.id in
-           TypeExpr.Arrow (Some (Label field_name), field.type_, res))
+           TypeExpr.Arrow (Some (Label field_name), (field.type_, []), (res, [])))
         res
         fields
 
 let searchable_type_of_record parent_type type_ =
-  Odoc_model.Lang.TypeExpr.Arrow (None, parent_type, type_)
+  Odoc_model.Lang.TypeExpr.Arrow (None, (parent_type, []), (type_, []))
 
 let convert_kind ~db (Odoc_index.Entry.{ kind; _ } as entry) =
   match kind with

sherlodoc/index/type_cache.ml

@@ -16,7 +16,8 @@ let rec of_odoc ~cache otyp =
   match otyp with
   | Odoc_model.Lang.TypeExpr.Var _str -> Any
   | Any -> Any
-  | Arrow (_lbl, left, right) -> cache (Arrow (of_odoc ~cache left, of_odoc ~cache right))
+  | Arrow (_lbl, (left, _), (right, _)) ->
+      cache (Arrow (of_odoc ~cache left, of_odoc ~cache right))
   | Constr (name, args) ->
       cache (Constr (Typename.to_string name, List.map (of_odoc ~cache) args))
   | Tuple li -> cache (Tuple (List.map (fun (_, ty) -> of_odoc ~cache ty) li))

src/document/generator.ml

@@ -325,6 +325,11 @@ module Make (Syntax : SYNTAX) = struct
 
     val with_kind_annotation : Odoc_model.Lang.Kind.t -> text -> text
   end = struct
+    let format_modes (modes : Odoc_model.Lang.Modes.t) =
+      match modes with
+      | [] -> O.noop
+      | ms -> O.txt " @ " ++ O.txt (String.concat ~sep:" " ms)
+
     let rec te_variant (t : Odoc_model.Lang.TypeExpr.Polymorphic_variant.t) =
       let style_arguments ~constant arguments =
         (* Multiple arguments in a polymorphic variant constructor correspond
@@ -494,35 +499,26 @@ module Make (Syntax : SYNTAX) = struct
           enclose_parens_if_needed
             (type_expr ~needs_parentheses:true te
             ++ O.txt " " ++ O.keyword "as" ++ O.txt " '" ++ O.txt alias)
-      | Arrow (None, src, dst) ->
-          let res =
-            O.span
-              ((O.box_hv @@ type_expr ~needs_parentheses:true src)
-              ++ O.txt " " ++ Syntax.Type.arrow)
-            ++ O.sp ++ type_expr dst
-            (* ++ O.end_hv *)
-          in
-          enclose_parens_if_needed res
-      | Arrow (Some (RawOptional _ as lbl), _src, dst) ->
-          let res =
-            O.span
-              (O.box_hv
-              @@ label lbl ++ O.txt ":"
-                 ++ tag "error" (O.txt "???")
-                 ++ O.txt " " ++ Syntax.Type.arrow)
-            ++ O.sp ++ type_expr dst
+      | Arrow (lbl, (src, src_modes), (dst, dst_modes)) ->
+          let src =
+            (O.box_hv @@ type_expr ~needs_parentheses:true src)
+            ++ format_modes src_modes
           in
-          enclose_parens_if_needed res
-      | Arrow (Some lbl, src, dst) ->
-          let res =
-            O.span
-              ((O.box_hv
-               @@ label lbl ++ O.txt ":" ++ O.cut
-                  ++ (O.box_hv @@ type_expr ~needs_parentheses:true src))
-              ++ O.txt " " ++ Syntax.Type.arrow)
-            ++ O.sp ++ type_expr dst
+          let labelized_src =
+            match lbl with
+            | None -> src
+            | Some (RawOptional _ as lbl) ->
+                O.box_hv
+                @@ label lbl ++ O.txt ":"
+                   ++ tag "error" (O.txt "???")
+                   ++ format_modes src_modes
+            | Some lbl -> O.box_hv @@ (label lbl ++ O.txt ":" ++ O.cut ++ src)
           in
-          enclose_parens_if_needed res
+          enclose_parens_if_needed
+            (O.span (labelized_src ++ O.txt " " ++ Syntax.Type.arrow)
+            ++ O.sp
+            ++ type_expr ~needs_parentheses:(dst_modes <> []) dst
+            ++ format_modes dst_modes)
       | Tuple lst -> tuple ~needs_parentheses ~boxed:true lst
       | Unboxed_tuple lst -> tuple ~needs_parentheses ~boxed:false lst
       | Constr (path, args) ->
@@ -1053,7 +1049,7 @@ module Make (Syntax : SYNTAX) = struct
     val value : Lang.Value.t -> Item.t
   end = struct
     let rec arity_of_type_expr = function
-      | Lang.TypeExpr.Arrow (_lbl, _arg, curried) ->
+      | Lang.TypeExpr.Arrow (_lbl, _arg, (curried, _modes)) ->
           1 + arity_of_type_expr curried
       | _ -> 0
 

src/loader/cmi.ml

@@ -548,16 +548,112 @@ let read_label_modalities ld =
 let read_constructor_argument arg =
   arg.ca_type, read_modalities Immutable arg.ca_modalities
 
+let tree_of_modes (modes : Mode.Alloc.Const.t) : string list =
+  (* Same as the OxCaml's [tree_of_modes]: axes whose value is legacy
+     or is implied by another axis are suppressed. *)
+  let forkable =
+    match modes.areality, modes.forkable with
+    | Local, Unforkable | Global, Forkable -> None
+    | _, _ -> Some modes.forkable
+  in
+  let yielding =
+    match modes.areality, modes.yielding with
+    | Local, Yielding | Global, Unyielding -> None
+    | _, _ -> Some modes.yielding
+  in
+  let contention =
+    match modes.visibility, modes.contention with
+    | Immutable, Contended
+    | Read, Shared
+    | Read_write, Uncontended -> None
+    | _, _ -> Some modes.contention
+  in
+  let portability =
+    match modes.statefulness, modes.portability with
+    | Stateless, Portable
+    | Observing, Shareable
+    | Stateful, Nonportable -> None
+    | _, _ -> Some modes.portability
+  in
+  let { Mode.Alloc.areality;
+        linearity;
+        uniqueness;
+        portability = _;
+        contention = _;
+        forkable = _;
+        yielding = _;
+        statefulness;
+        visibility;
+        staticity
+      } = Mode.Alloc.Const.diff modes Mode.Alloc.Const.legacy
+  in
+  let print_opt print a = Option.map (Format_doc.asprintf "%a" print) a in
+  List.filter_map (fun x -> x)
+    [ print_opt Mode.Locality.Const.print areality
+    ; print_opt Mode.Uniqueness.Const.print uniqueness
+    ; print_opt Mode.Linearity.Const.print linearity
+    ; print_opt Mode.Portability.Const.print portability
+    ; print_opt Mode.Contention.Const.print contention
+    ; print_opt Mode.Forkable.Const.print forkable
+    ; print_opt Mode.Yielding.Const.print yielding
+    ; print_opt Mode.Statefulness.Const.print statefulness
+    ; print_opt Mode.Visibility.Const.print visibility
+    ; print_opt Mode.Staticity.Const.print staticity ]
+
+let read_alloc_modes m = tree_of_modes (Mode.Alloc.zap_to_legacy m)
+
+type modes = Mode.Alloc.Const.t
+
+let legacy_modes = Mode.Alloc.Const.legacy
+
+let curried_acc modes arg_mode =
+  Ctype.curry_mode modes (Mode.Alloc.zap_to_legacy arg_mode)
+
+let mode_is_implied implied_modes res_mode =
+  let snap = Btype.snapshot () in
+  let implied =
+    match Mode.Alloc.equate (Mode.Alloc.of_const implied_modes) res_mode with
+    | Ok () -> true
+    | Error _ -> false
+  in
+  Btype.backtrack snap;
+  implied
+
+let read_arrow_modes implied_modes typ =
+  match Compat.get_desc typ with
+  | Tarrow ((_, arg_mode, res_mode), _, res, _) ->
+      let arg_modes = read_alloc_modes arg_mode in
+      let implied_modes = curried_acc implied_modes arg_mode in
+      let res_is_arrow =
+        match Compat.get_desc res with
+        | Tarrow _ -> not (is_aliased (proxy res))
+        | _ -> false
+      in
+      let res_modes =
+        if res_is_arrow && mode_is_implied implied_modes res_mode then []
+        else read_alloc_modes res_mode
+      in
+      (arg_modes, res_modes, implied_modes)
+  | _ -> ([], [], implied_modes)
+
 #else
 
 let jkind_of_type_desc _te = Kind.Default
 let read_value_descr_modalities _vd = []
 let read_label_modalities _ld = []
 let read_constructor_argument arg = arg, []
 
+type modes = unit
+
+let legacy_modes : modes = ()
+
+let read_arrow_modes (implied_modes : modes) _typ = ([], [], implied_modes)
+
 #endif
 
-let rec read_type_expr env typ =
+let rec read_type_expr env typ = read_type_expr_modal env legacy_modes typ
+
+and read_type_expr_modal env implied_modes typ =
   let open TypeExpr in
   let px = proxy typ in
   if used_alias px then Var (name_of_type typ)
@@ -592,8 +688,9 @@ let rec read_type_expr env typ =
             | _ ->
               lbl, read_type_expr env arg
           in
-          let res = read_type_expr env res in
-            Arrow(lbl, arg, res)
+          let arg_modes, res_modes, modes = read_arrow_modes implied_modes typ in
+          let res = read_type_expr_modal env implied_modes res in
+            Arrow(lbl, (arg, arg_modes), (res, res_modes))
       | Ttuple typs ->
 #if OCAML_VERSION >= (5,4,0) || defined OXCAML
           let typs = List.map (fun (lbl,x) -> lbl, read_type_expr env x) typs in

src/loader/cmi.mli

@@ -108,8 +108,19 @@ val read_modalities :
 val read_value_modalities :
   Mode.Modality.t ->
   Odoc_model.Lang.Modalities.t
+
+val tree_of_modes : Mode.Alloc.Const.t -> Odoc_model.Lang.Modes.t
 #endif
 
+type modes
+
+val legacy_modes : modes
+
+val read_arrow_modes :
+  modes ->
+  Types.type_expr ->
+  Odoc_model.Lang.Modes.t * Odoc_model.Lang.Modes.t * modes
+
 val read_value_descr_modalities :
   Types.value_description ->
   Odoc_model.Lang.Modalities.t

src/loader/cmt.ml

@@ -288,10 +288,13 @@ let rec read_class_field env parent cf =
         | Tcfk_concrete(_, expr) ->
             (* Types of concrete methods in class implementation begin
                with the object as first (implicit) argument, so we
-               must keep only the type after the first arrow. *)
+               must keep only the type after the first arrow. That
+               arrow's modes are always legacy, since a method type
+               cannot carry a mode annotation. *)
             let type_ =
               match Cmi.read_type_expr env expr.exp_type with
-              | Arrow (_, _, t) -> t
+              | Arrow (_, _, (t, [])) -> t
+              | Arrow (_, _, (_, _ :: _)) -> invalid_arg "unexpected modes on method"
               | t -> t
             in
             false, type_

src/loader/cmti.ml

@@ -41,6 +41,9 @@ let opt_map f = function
 let read_label = Cmi.read_label
 
 let rec read_core_type env container ctyp =
+  read_core_type_modal env Cmi.legacy_modes container ctyp
+
+and read_core_type_modal env modes container ctyp =
   let open TypeExpr in
     match ctyp.ctyp_desc with
 #if defined OXCAML
@@ -59,8 +62,11 @@ let rec read_core_type env container ctyp =
 #endif
         let lbl = read_label lbl in
         let arg = read_core_type env container arg in
-        let res = read_core_type env container res in
-          Arrow(lbl, arg, res)
+        let arg_modes, res_modes, modes =
+          Cmi.read_arrow_modes modes ctyp.ctyp_type
+        in
+        let res = read_core_type_modal env modes container res in
+          Arrow(lbl, (arg, arg_modes), (res, res_modes))
     | Ttyp_tuple typs ->
 #if OCAML_VERSION >= (5,4,0) || defined OXCAML
         let typs = List.map (fun (lbl,x) -> lbl, read_core_type env container x) typs in

src/model/lang.ml

@@ -217,6 +217,11 @@ and Modalities : sig
 end =
   Modalities
 
+and Modes : sig
+  type t = string list
+end =
+  Modes
+
 and TypeDecl : sig
   module Field : sig
     type t = {
@@ -496,7 +501,7 @@ and TypeExpr : sig
     | Var of string
     | Any
     | Alias of t * string
-    | Arrow of label option * t * t
+    | Arrow of label option * with_modes * with_modes
     | Tuple of (string option * t) list
     | Unboxed_tuple of (string option * t) list
     | Constr of Path.Type.t * t list
@@ -508,6 +513,8 @@ and TypeExpr : sig
     | Splice of t
     | Package of TypeExpr.Package.t
     | Arrow_functor of label option * Module.t * t
+
+  and with_modes = t * Modes.t
 end =
   TypeExpr
 

src/model_desc/lang_desc.ml

@@ -683,7 +683,10 @@ and typeexpr_t =
         C
           ( "Arrow",
             (x1, x2, x3),
-            Triple (Option typeexpr_label, typeexpr_t, typeexpr_t) )
+            Triple
+              ( Option typeexpr_label,
+                Pair (typeexpr_t, List string),
+                Pair (typeexpr_t, List string) ) )
     | Tuple x -> C ("Tuple", x, List (Pair (Option string, typeexpr_t)))
     | Unboxed_tuple x ->
         C ("Unboxed_tuple", x, List (Pair (Option string, typeexpr_t)))

src/xref2/compile.ml

@@ -887,14 +887,14 @@ and handle_arrow :
     Env.t ->
     Id.Id.label_parent ->
     TypeExpr.label option ->
-    TypeExpr.t ->
-    TypeExpr.t ->
+    TypeExpr.with_modes ->
+    TypeExpr.with_modes ->
     TypeExpr.t =
- fun env parent lbl t1 t2 ->
-  let t2' = type_expression env parent t2 in
+ fun env parent lbl (t1, m1) (t2, m2) ->
+  let t2' = (type_expression env parent t2, m2) in
   match lbl with
   | Some (Optional _ | Label _) | None ->
-      Arrow (lbl, type_expression env parent t1, t2')
+      Arrow (lbl, (type_expression env parent t1, m1), t2')
   | Some (RawOptional s) -> (
       (* s is definitely an option type, but not _obviously_ so. *)
       match Component.Of_Lang.(type_expression (empty ()) t1) with
@@ -916,10 +916,14 @@ and handle_arrow :
           in
           match find_option p with
           | Some t1 ->
-              Arrow (Some (Optional s), type_expression env parent t1, t2')
+              Arrow (Some (Optional s), (type_expression env parent t1, m1), t2')
           | None ->
-              Arrow (Some (RawOptional s), type_expression env parent t1, t2'))
-      | _ -> Arrow (Some (RawOptional s), type_expression env parent t1, t2'))
+              Arrow
+                (Some (RawOptional s), (type_expression env parent t1, m1), t2')
+          )
+      | _ ->
+          Arrow (Some (RawOptional s), (type_expression env parent t1, m1), t2')
+      )
 
 and type_expression : Env.t -> Id.LabelParent.t -> _ -> _ =
  fun env parent texpr ->