OCaml 5.4: labelled tuple and bivariance

Add support for labelled tuple (x:int * y:int) and bivariance in odoc
model.

Author: Octachron

sherlodoc/index/load_doc.ml

@@ -81,7 +81,8 @@ let searchable_type_of_constructor args res =
   match args with
   | TypeDecl.Constructor.Tuple args -> begin
       match args with
-      | _ :: _ :: _ -> TypeExpr.(Arrow (None, Tuple args, res))
+      | _ :: _ :: _ ->
+          TypeExpr.(Arrow (None, Tuple (List.map (fun x -> None, x) args), res))
       | [ arg ] -> TypeExpr.(Arrow (None, arg, res))
       | _ -> res
     end

sherlodoc/index/type_cache.ml

@@ -19,5 +19,5 @@ let rec of_odoc ~cache otyp =
   | 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 (of_odoc ~cache) li))
+  | Tuple li -> cache (Tuple (List.map (fun (_, ty) -> of_odoc ~cache ty) li))
   | _ -> Unhandled

src/document/generator.ml

@@ -448,7 +448,13 @@ module Make (Syntax : SYNTAX) = struct
           let res =
             O.box_hv_no_indent
               (O.list lst ~sep:Syntax.Type.Tuple.element_separator
-                 ~f:(type_expr ~needs_parentheses:true))
+                 ~f:(fun (lbl, ty) ->
+                   match lbl with
+                   | None -> type_expr ~needs_parentheses:true ty
+                   | Some lbl ->
+                       tag "label" (O.txt lbl)
+                       ++ O.txt ":" ++ O.cut
+                       ++ type_expr ~needs_parentheses:true ty))
           in
           if Syntax.Type.Tuple.always_parenthesize || needs_parentheses then
             enclose ~l:"(" res ~r:")"
@@ -772,6 +778,7 @@ module Make (Syntax : SYNTAX) = struct
           | None -> desc
           | Some Odoc_model.Lang.TypeDecl.Pos -> "+" :: desc
           | Some Odoc_model.Lang.TypeDecl.Neg -> "-" :: desc
+          | Some Odoc_model.Lang.TypeDecl.Bivariant -> "+" :: "-" :: desc
         in
         let final = if injectivity then "!" :: var_desc else var_desc in
         String.concat ~sep:"" final

src/loader/cmi.ml

@@ -467,7 +467,7 @@ let rec read_type_expr env typ =
           let res = read_type_expr env res in
             Arrow(lbl, arg, res)
       | Ttuple typs ->
-          let typs = List.map (read_type_expr env) typs in
+          let typs = List.map (fun x -> None, read_type_expr env x) typs in
             Tuple typs
       | Tconstr(p, params, _) ->
           let p = Env.Path.read_type env.ident_env p in

src/loader/cmti.ml

@@ -64,7 +64,7 @@ let rec read_core_type env container ctyp =
         let res = read_core_type env container res in
           Arrow(lbl, arg, res)
     | Ttyp_tuple typs ->
-        let typs = List.map (read_core_type env container) typs in
+        let typs = List.map (fun x -> None, read_core_type env container x) typs in
           Tuple typs
     | Ttyp_constr(p, _, params) ->
         let p = Env.Path.read_type env.ident_env p in

src/model/lang.ml

@@ -231,7 +231,7 @@ and TypeDecl : sig
       | Extensible
   end
 
-  type variance = Pos | Neg
+  type variance = Pos | Neg | Bivariant
 
   type param_desc = Any | Var of string
 
@@ -439,7 +439,7 @@ and TypeExpr : sig
     | Any
     | Alias of t * string
     | Arrow of label option * t * t
-    | Tuple of t list
+    | Tuple of (string option * t) list
     | Constr of Path.Type.t * t list
     | Polymorphic_variant of TypeExpr.Polymorphic_variant.t
     | Object of TypeExpr.Object.t

src/model_desc/lang_desc.ml

@@ -336,7 +336,8 @@ and typedecl_representation =
 
 and typedecl_variance =
   let open Lang.TypeDecl in
-  Variant (function Pos -> C0 "Pos" | Neg -> C0 "Neg")
+  Variant
+    (function Pos -> C0 "Pos" | Neg -> C0 "Neg" | Bivariant -> C0 "Bivariant")
 
 and typedecl_param_desc =
   let open Lang.TypeDecl in
@@ -628,7 +629,7 @@ and typeexpr_t =
           ( "Arrow",
             (x1, x2, x3),
             Triple (Option typeexpr_label, typeexpr_t, typeexpr_t) )
-    | Tuple x -> C ("Tuple", x, List typeexpr_t)
+    | Tuple x -> C ("Tuple", x, List (Pair (Option string, typeexpr_t)))
     | Constr (x1, x2) ->
         C ("Constr", ((x1 :> Paths.Path.t), x2), Pair (path, List typeexpr_t))
     | Polymorphic_variant x ->

src/search/html.ml

@@ -35,7 +35,8 @@ let display_constructor_args args =
   match args with
   | TypeDecl.Constructor.Tuple args ->
       (match args with
-      | _ :: _ :: _ -> Some TypeExpr.(Tuple args)
+      | _ :: _ :: _ ->
+          Some TypeExpr.(Tuple (List.map (fun x -> (None, x)) args))
       | [ arg ] -> Some arg
       | _ -> None)
       |> map_option Text.of_type
@@ -63,6 +64,7 @@ let typedecl_params ?(delim = `parens) params =
       | None -> desc
       | Some TypeDecl.Pos -> "+" :: desc
       | Some TypeDecl.Neg -> "-" :: desc
+      | Some TypeDecl.Bivariant -> "+" :: "-" :: desc
     in
     let final = if injectivity then "!" :: var_desc else var_desc in
     String.concat "" final

src/xref2/compile.ml

@@ -903,7 +903,9 @@ and type_expression : Env.t -> Id.LabelParent.t -> _ -> _ =
   | Var _ | Any -> texpr
   | Alias (t, str) -> Alias (type_expression env parent t, str)
   | Arrow (lbl, t1, t2) -> handle_arrow env parent lbl t1 t2
-  | Tuple ts -> Tuple (List.map (type_expression env parent) ts)
+  | Tuple ts ->
+      Tuple
+        (List.map (fun (lbl, ty) -> (lbl, type_expression env parent ty)) ts)
   | Constr (path, ts') -> (
       let cp = Component.Of_Lang.(type_path (empty ()) path) in
       let ts = List.map (type_expression env parent) ts' in

src/xref2/component.ml

@@ -122,7 +122,7 @@ and TypeExpr : sig
     | Any
     | Alias of t * string
     | Arrow of label option * t * t
-    | Tuple of t list
+    | Tuple of (string option * t) list
     | Constr of Cpath.type_ * t list
     | Polymorphic_variant of TypeExpr.Polymorphic_variant.t
     | Object of TypeExpr.Object.t
@@ -1010,7 +1010,7 @@ module Fmt = struct
   and type_decl_constructor_arg c ppf =
     let open TypeDecl.Constructor in
     function
-    | Tuple ts -> type_tuple c ppf ts
+    | Tuple ts -> type_constructor_params c ppf ts
     | Record fs -> type_decl_fields c ppf fs
 
   and type_decl_field c ppf t =
@@ -1021,13 +1021,18 @@ module Fmt = struct
   and type_decl_fields c ppf fs =
     fpp_list "; " "{ %a }" (type_decl_field c) ppf fs
 
-  and type_tuple c ppf ts = fpp_list " * " "%a" (type_expr c) ppf ts
+  and type_constructor_params c ppf ts =
+    fpp_list " * " "%a" (type_expr c) ppf ts
 
   and type_param ppf t =
     let desc =
       match t.Odoc_model.Lang.TypeDecl.desc with Any -> "_" | Var n -> n
     and variance =
-      match t.variance with Some Pos -> "+" | Some Neg -> "-" | None -> ""
+      match t.variance with
+      | Some Pos -> "+"
+      | Some Neg -> "-"
+      | Some Bivariant -> "+-"
+      | None -> ""
     and injectivity = if t.injectivity then "!" else "" in
     Format.fprintf ppf "%s%s%s" variance injectivity desc
 
@@ -1086,6 +1091,18 @@ module Fmt = struct
         Format.fprintf ppf "%a * %a" (type_expr c) t (type_expr_list c) ts
     | [] -> ()
 
+  and type_labeled_tuple c ppf l =
+    match l with
+    | [ t ] -> with_label c ppf t
+    | t :: ts ->
+        Format.fprintf ppf "%a * %a" (with_label c) t (type_labeled_tuple c) ts
+    | [] -> ()
+
+  and with_label c ppf (l, ty) =
+    match l with
+    | None -> type_expr c ppf ty
+    | Some lbl -> Format.fprintf ppf "%s:%a" lbl (type_expr c) ty
+
   and type_object _c ppf _o = Format.fprintf ppf "(object)"
 
   and type_class c ppf (x, ys) =
@@ -1121,7 +1138,7 @@ module Fmt = struct
     | Arrow (l, t1, t2) ->
         Format.fprintf ppf "%a(%a) -> %a" type_expr_label l (type_expr c) t1
           (type_expr c) t2
-    | Tuple ts -> Format.fprintf ppf "(%a)" (type_expr_list c) ts
+    | Tuple ts -> Format.fprintf ppf "(%a)" (type_labeled_tuple c) ts
     | Constr (p, args) -> (
         match args with
         | [] -> Format.fprintf ppf "%a" (type_path c) p
@@ -2244,7 +2261,9 @@ module Of_Lang = struct
         Constr (type_path ident_map p, List.map (type_expression ident_map) xs)
     | Arrow (lbl, t1, t2) ->
         Arrow (lbl, type_expression ident_map t1, type_expression ident_map t2)
-    | Tuple ts -> Tuple (List.map (type_expression ident_map) ts)
+    | Tuple ts ->
+        Tuple
+          (List.map (fun (lbl, ty) -> (lbl, type_expression ident_map ty)) ts)
     | Polymorphic_variant v ->
         Polymorphic_variant (type_expr_polyvar ident_map v)
     | Poly (s, ts) -> Poly (s, type_expression ident_map ts)