OxCaml: Support for modalities

CHANGES.md

@@ -5,6 +5,7 @@
 - `markdown-generate` command now accepts multiple `.odocl` files in a single
   invocation, eliminating the need for shell scripting (@davesnx, #1387)
 - Support for OxCaml (@lukemaurer, @art-w, #1399)
+- Support for OxCaml kind annotations (@art-w, #1410)
 
 ### Fixed
 - Fix compile-time crashing bugs #930 and #1385 (@jonludlam, #1400)

sherlodoc/index/load_doc.ml

@@ -82,8 +82,8 @@ let searchable_type_of_constructor args res =
   | TypeDecl.Constructor.Tuple args -> begin
       match args with
       | _ :: _ :: _ ->
-          TypeExpr.(Arrow (None, Tuple (List.map (fun x -> 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 ->

src/document/generator.ml

@@ -306,6 +306,10 @@ module Make (Syntax : SYNTAX) = struct
 
     val format_type_path :
       delim:[ `parens | `brackets ] -> Lang.TypeExpr.t list -> text -> text
+
+    val kind_annotation : Odoc_model.Lang.KindAnnotation.t -> text
+
+    val with_kind_annotation : Odoc_model.Lang.KindAnnotation.t -> text -> text
   end = struct
     let rec te_variant (t : Odoc_model.Lang.TypeExpr.Polymorphic_variant.t) =
       let style_arguments ~constant arguments =
@@ -426,6 +430,30 @@ module Make (Syntax : SYNTAX) = struct
       then enclose ~l:lparen res ~r:")"
       else res
 
+    and kind_annotation (k : Odoc_model.Lang.KindAnnotation.t) =
+      match k with
+      | Default -> O.noop
+      | Abbreviation s -> O.txt s
+      | Mod (base, modes) ->
+          kind_annotation base ++ O.txt " " ++ O.keyword "mod"
+          ++ O.txt (" " ^ String.concat ~sep:" " modes)
+      | With (base, ty, modalities) -> (
+          kind_annotation base ++ O.txt " " ++ O.keyword "with" ++ O.txt " "
+          ++ type_expr ty
+          ++
+          match modalities with
+          | [] -> O.noop
+          | mods ->
+              O.txt " " ++ O.keyword "mod"
+              ++ O.txt (" " ^ String.concat ~sep:" " mods))
+      | Kind_of ty -> O.keyword "kind_of_" ++ O.txt " " ++ type_expr ty
+      | Product ks -> O.list ks ~sep:(O.txt " & ") ~f:kind_annotation
+
+    and with_kind_annotation kind base =
+      match kind with
+      | Odoc_model.Lang.KindAnnotation.Default -> base
+      | k -> O.txt "(" ++ base ++ O.txt " : " ++ kind_annotation k ++ O.txt ")"
+
     and type_expr ?(needs_parentheses = false) (t : Odoc_model.Lang.TypeExpr.t)
         =
       let enclose_parens_if_needed res =
@@ -478,9 +506,11 @@ module Make (Syntax : SYNTAX) = struct
           format_type_path ~delim:`brackets args
             (Link.from_path (path :> Paths.Path.t))
       | Poly (polyvars, t) ->
-          enclose_parens_if_needed
-          @@ O.txt ("'" ^ String.concat ~sep:" '" polyvars ^ ". ")
-             ++ type_expr t
+          let format_poly_var (name, kind) =
+            with_kind_annotation kind (O.txt ("'" ^ name))
+          in
+          let vars = O.list polyvars ~sep:(O.txt " ") ~f:format_poly_var in
+          enclose_parens_if_needed @@ (vars ++ O.txt ". " ++ type_expr t)
       | Quote t -> O.span (O.txt "<[ " ++ O.box_hv (type_expr t) ++ O.txt " ]>")
       | Splice t -> O.span (O.txt "$" ++ type_expr ~needs_parentheses:true t)
       | Package pkg ->
@@ -537,23 +567,29 @@ module Make (Syntax : SYNTAX) = struct
       text * bool
 
     val format_constraints : (Lang.TypeExpr.t * Lang.TypeExpr.t) list -> text
+
+    val format_modalities : Odoc_model.Lang.Modalities.t -> text
   end = struct
+    let format_modalities modalities =
+      match modalities with
+      | [] -> O.noop
+      | mods ->
+          O.txt " " ++ O.txt "@@" ++ O.txt " "
+          ++ O.txt (String.concat ~sep:" " mods)
+
     let record fields =
-      let field mutable_ id typ =
+      let field mutable_ id typ modalities =
         let url = Url.from_identifier ~stop_before:true id in
         let name = Paths.Identifier.name id in
         let attrs = [ "def"; "record"; Url.Anchor.string_of_kind url.kind ] in
         let cell =
-          (* O.td ~a:[ O.a_class ["def"; kind ] ]
-           *   [O.a ~a:[O.a_href ("#" ^ anchor); O.a_class ["anchor"]] []
-           *   ; *)
           O.code
             ((if mutable_ then O.keyword "mutable" ++ O.txt " " else O.noop)
             ++ O.txt name
             ++ O.txt Syntax.Type.annotation_separator
             ++ type_expr typ
+            ++ format_modalities modalities
             ++ O.txt Syntax.Type.Record.field_separator)
-          (* ] *)
         in
         (url, attrs, cell)
       in
@@ -562,7 +598,9 @@ module Make (Syntax : SYNTAX) = struct
         |> List.map (fun fld ->
                let open Odoc_model.Lang.TypeDecl.Field in
                let url, attrs, code =
-                 field fld.mutable_ (fld.id :> Paths.Identifier.t) fld.type_
+                 field fld.mutable_
+                   (fld.id :> Paths.Identifier.t)
+                   fld.type_ fld.modalities
                in
                let anchor = Some url in
                let doc = fld.doc.elements in
@@ -640,7 +678,9 @@ module Make (Syntax : SYNTAX) = struct
       | Tuple lst ->
           let params =
             O.list lst ~sep:Syntax.Type.Tuple.element_separator
-              ~f:(type_expr ~needs_parentheses:is_gadt)
+              ~f:(fun (te, mods) ->
+                type_expr ~needs_parentheses:is_gadt te
+                ++ format_modalities mods)
           in
           O.documentedSrc
             (cstr
@@ -821,8 +861,8 @@ module Make (Syntax : SYNTAX) = struct
         Odoc_model.Lang.TypeDecl.param list ->
         text =
      fun ?(delim = `parens) params ->
-      let format_param { Odoc_model.Lang.TypeDecl.desc; variance; injectivity }
-          =
+      let format_param_str
+          { Odoc_model.Lang.TypeDecl.desc; variance; injectivity; kind = _ } =
         let desc =
           match desc with
           | Odoc_model.Lang.TypeDecl.Any -> [ "_" ]
@@ -838,15 +878,22 @@ module Make (Syntax : SYNTAX) = struct
         let final = if injectivity then "!" :: var_desc else var_desc in
         String.concat ~sep:"" final
       in
-      O.txt
-        (match params with
-        | [] -> ""
-        | [ x ] -> format_param x |> Syntax.Type.handle_format_params
-        | lst -> (
-            let params = String.concat ~sep:", " (List.map format_param lst) in
-            (match delim with `parens -> "(" | `brackets -> "[")
-            ^ params
-            ^ match delim with `parens -> ")" | `brackets -> "]"))
+      let format_param p =
+        Type_expression.with_kind_annotation p.Odoc_model.Lang.TypeDecl.kind
+          (O.txt (format_param_str p))
+      in
+      match params with
+      | [] -> O.noop
+      | [ x ] ->
+          let base = format_param_str x |> Syntax.Type.handle_format_params in
+          Type_expression.with_kind_annotation x.kind (O.txt base)
+      | lst ->
+          let left, right =
+            match delim with `parens -> ("(", ")") | `brackets -> ("[", "]")
+          in
+          O.txt left
+          ++ O.list lst ~sep:(O.txt ", ") ~f:format_param
+          ++ O.txt right
 
     let format_constraints constraints =
       O.list constraints ~f:(fun (t1, t2) ->
@@ -896,7 +943,12 @@ module Make (Syntax : SYNTAX) = struct
             let params = format_params l in
             Syntax.Type.handle_constructor_params (O.txt tyname) params
       in
-      let intro = keyword' ++ O.txt " " ++ tconstr in
+      let kind_annot =
+        match t.equation.kind with
+        | Default -> O.noop
+        | k -> O.txt " : " ++ Type_expression.kind_annotation k
+      in
+      let intro = keyword' ++ O.txt " " ++ tconstr ++ kind_annot in
       let constraints = format_constraints t.equation.constraints in
       let manifest, need_private, long_prefix =
         match t.equation.manifest with
@@ -978,6 +1030,7 @@ module Make (Syntax : SYNTAX) = struct
              ++ O.txt " " ++ O.txt name
              ++ O.txt Syntax.Type.annotation_separator
              ++ O.cut ++ type_expr t.type_
+             ++ Type_declaration.format_modalities t.modalities
              ++ if semicolon then O.txt ";" else O.noop)
       in
       let attr = [ "value" ] @ extra_attr in

src/loader/cmi.ml

@@ -490,6 +490,63 @@ let mark_class_declaration cld =
   List.iter mark_type_parameter cld.cty_params;
   mark_class_type cld.cty_params cld.cty_type
 
+#if defined OXCAML
+let read_parsetree_core_type (ct : Parsetree.core_type) =
+  let open TypeExpr in
+  match ct.ptyp_desc with
+  | Ptyp_var (s, _) -> Var s
+  | Ptyp_any _ -> Any
+  | _ -> failwith "invalid core type"
+
+let rec read_jkind_annotation (jk : Parsetree.jkind_annotation) =
+  let open KindAnnotation in
+  match jk.pjkind_desc with
+  | Pjk_default -> Default
+  | Pjk_abbreviation s -> Abbreviation s
+  | Pjk_mod (jk', modes) ->
+    let modes = List.map (fun (m : Parsetree.mode Location.loc) ->
+      let (Parsetree.Mode s) = m.txt in s) modes in
+    Mod (read_jkind_annotation jk', modes)
+  | Pjk_with (jk', cty, modalities) ->
+    let ty = read_parsetree_core_type cty in
+    let modalities = List.map (fun (m : Parsetree.modality Location.loc) ->
+      let (Parsetree.Modality s) = m.txt in s) modalities in
+    With (read_jkind_annotation jk', ty, modalities)
+  | Pjk_kind_of cty ->
+    Kind_of (read_parsetree_core_type cty)
+  | Pjk_product jks ->
+    Product (List.map read_jkind_annotation jks)
+
+let read_jkind_annotation = function
+  | None -> KindAnnotation.Default
+  | Some jk ->
+    match read_jkind_annotation jk with
+    | Abbreviation "value" -> Default
+    | k -> k
+
+let jkind_of_type_desc te =
+  match  te with
+  | Tvar { jkind; _ } | Tunivar { jkind; _ } ->
+      read_jkind_annotation jkind.annotation
+  | _ -> KindAnnotation.Default
+
+let read_modalities mut modalities =
+  Typemode.untransl_modalities mut modalities
+  |> List.map (fun (m : Parsetree.modality Location.loc) ->
+    let (Parsetree.Modality s) = m.txt in s)
+
+let read_value_modalities modalities =
+  let const =
+    Ctype.zap_modalities_to_floor_if_modes_enabled_at Alpha modalities
+  in
+  read_modalities Immutable const
+
+#else
+
+let jkind_of_type_desc _te = KindAnnotation.Default
+
+#endif
+
 let rec read_type_expr env typ =
   let open TypeExpr in
   let px = proxy typ in
@@ -549,10 +606,14 @@ let rec read_type_expr env typ =
       | Tpoly (typ, []) -> read_type_expr env typ
       | Tpoly (typ, tyl) ->
           let tyl = List.map Compat.repr tyl in
-          let vars = List.map name_of_type_repr tyl in
+          let vars_with_kinds = List.map (fun ty ->
+            let name = name_of_type_repr ty in
+            let kind = jkind_of_type_desc ty.desc in
+            (name, kind)
+          ) tyl in
           let typ = read_type_expr env typ in
             remove_names tyl;
-            Poly(vars, typ)
+            Poly(vars_with_kinds, typ)
       | Tunivar _ -> Var (name_of_type typ)
 #if OCAML_VERSION>=(5,4,0)
       | Tpackage {pack_path=p; pack_cstrs } ->
@@ -723,7 +784,14 @@ let read_value_description ({ident_env ; warnings_tag} as env) parent id vd =
         External primitives
     | _ -> assert false
   in
-  Value { Value.id; source_loc; doc; type_; value }
+  let modalities =
+#if defined OXCAML
+    read_value_modalities vd.val_modalities
+#else
+    []
+#endif
+  in
+  Value { Value.id; source_loc; doc; type_; value; modalities }
 
 #if defined OXCAML
 let is_mutable = Types.is_mutable
@@ -741,21 +809,36 @@ let read_label_declaration env parent ld =
   in
   let mutable_ = is_mutable ld.ld_mutable in
   let type_ = read_type_expr env ld.ld_type in
-    {id; doc; mutable_; type_}
+  let modalities =
+#if defined OXCAML
+    read_modalities ld.ld_mutable ld.ld_modalities
+#else
+    []
+#endif
+  in
+    {id; doc; mutable_; type_; modalities}
 
 let read_constructor_declaration_arguments env parent arg =
 #if OCAML_VERSION < (4,3,0)
   (* NOTE(@ostera): constructor with inlined records were introduced post 4.02
      so it's safe to use Tuple here *)
   ignore parent;
-  TypeDecl.Constructor.Tuple(List.map (read_type_expr env) arg)
+  TypeDecl.Constructor.Tuple(List.map (fun x -> read_type_expr env x, []) arg)
 #else
   let open TypeDecl.Constructor in
     match arg with
 #if defined OXCAML
-    | Cstr_tuple args -> Tuple (List.map (fun arg -> read_type_expr env arg.ca_type) args)
+    | Cstr_tuple args ->
+        let args_with_modalities =
+          List.map
+            (fun arg ->
+              read_type_expr env arg.ca_type,
+              read_modalities Immutable arg.ca_modalities)
+            args
+        in
+        Tuple args_with_modalities
 #else
-    | Cstr_tuple args -> Tuple (List.map (read_type_expr env) args)
+    | Cstr_tuple args -> Tuple (List.map (fun arg -> read_type_expr env arg, []) args)
 #endif
     | Cstr_record lds ->
         Record (List.map (read_label_declaration env parent) lds)
@@ -827,6 +910,7 @@ let read_type_parameter abstr var param =
     if name = "_" then Any
     else Var name
   in
+  let kind = jkind_of_type_desc (Compat.get_desc param) in
   let variance =
     if not (abstr || aliasable param) then None
     else begin
@@ -836,7 +920,7 @@ let read_type_parameter abstr var param =
         else None
       end in
   let injectivity = read_injectivity var in
-  {desc; variance; injectivity}
+  {desc; variance; injectivity; kind}
 
 let read_type_constraints env params =
   List.fold_right
@@ -898,7 +982,14 @@ let read_type_declaration env parent id decl =
     List.map2 (read_type_parameter abstr) decl.type_variance params
   in
   let private_ = (decl.type_private = Private) in
-  let equation = Equation.{params; manifest; constraints; private_} in
+  let kind =
+#if defined OXCAML
+    read_jkind_annotation decl.type_jkind.annotation
+#else
+    KindAnnotation.Default
+#endif
+  in
+  let equation = Equation.{params; manifest; constraints; private_; kind} in
   {id; source_loc; doc; canonical; equation; representation}
 
 let read_extension_constructor env parent id ext =

src/loader/cmi.mli

@@ -96,3 +96,18 @@ val read_extension_constructor : env ->
 val read_exception : env ->
   Paths.Identifier.Signature.t -> Ident.t ->
   Types.extension_constructor -> Odoc_model.Lang.Exception.t
+
+#if defined OXCAML
+val read_jkind_annotation :
+  Parsetree.jkind_annotation option ->
+  Odoc_model.Lang.KindAnnotation.t
+
+val read_modalities :
+  Types.mutability ->
+  Mode.Modality.Const.t ->
+  Odoc_model.Lang.Modalities.t
+
+val read_value_modalities :
+  Mode.Modality.t ->
+  Odoc_model.Lang.Modalities.t
+#endif