Skip to content

Commit a1f6bca

Browse files
art-wart-w
committed
OxCaml: Support for modalities
1 parent e446303 commit a1f6bca

32 files changed

Lines changed: 349 additions & 185 deletions

File tree

‎sherlodoc/index/load_doc.ml‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -82,8 +82,8 @@ let searchable_type_of_constructor args res =
8282
| TypeDecl.Constructor.Tuple args -> begin
8383
match args with
8484
| _ :: _ :: _ ->
85-
TypeExpr.(Arrow (None, Tuple (List.map (fun x -> None, x) args), res))
86-
| [ arg ] -> TypeExpr.(Arrow (None, arg, res))
85+
TypeExpr.Arrow (None, Tuple (List.map (fun (x, _mods) -> None, x) args), res)
86+
| [ (arg, _) ] -> TypeExpr.Arrow (None, arg, res)
8787
| _ -> res
8888
end
8989
| TypeDecl.Constructor.Record fields ->

‎src/document/generator.ml‎

Lines changed: 20 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -304,6 +304,16 @@ module Make (Syntax : SYNTAX) = struct
304304
{ Source_page.url; contents }
305305
end
306306

307+
module Modalities : sig
308+
val format : Odoc_model.Lang.Modalities.t -> text
309+
end = struct
310+
let format = function
311+
| [] -> O.noop
312+
| mods ->
313+
O.txt " " ++ O.txt "@@" ++ O.txt " "
314+
++ O.txt (String.concat ~sep:" " mods)
315+
end
316+
307317
module Type_expression : sig
308318
val type_expr : ?needs_parentheses:bool -> Lang.TypeExpr.t -> text
309319

@@ -454,10 +464,7 @@ module Make (Syntax : SYNTAX) = struct
454464
let res =
455465
kind_annotation ~needs_parentheses:true base
456466
++ O.txt " " ++ O.keyword "with" ++ O.txt " " ++ type_expr ty
457-
++
458-
match modalities with
459-
| [] -> O.noop
460-
| mods -> O.txt " @@ " ++ O.txt (String.concat ~sep:" " mods)
467+
++ Modalities.format modalities
461468
in
462469
enclose_parens_if_needed res
463470
| Kind_of ty ->
@@ -607,21 +614,18 @@ module Make (Syntax : SYNTAX) = struct
607614
val format_constraints : (Lang.TypeExpr.t * Lang.TypeExpr.t) list -> text
608615
end = struct
609616
let record fields =
610-
let field mutable_ id typ =
617+
let field mutable_ id typ modalities =
611618
let url = Url.from_identifier ~stop_before:true id in
612619
let name = Paths.Identifier.name id in
613620
let attrs = [ "def"; "record"; Url.Anchor.string_of_kind url.kind ] in
614621
let cell =
615-
(* O.td ~a:[ O.a_class ["def"; kind ] ]
616-
* [O.a ~a:[O.a_href ("#" ^ anchor); O.a_class ["anchor"]] []
617-
* ; *)
618622
O.code
619623
((if mutable_ then O.keyword "mutable" ++ O.txt " " else O.noop)
620624
++ O.txt name
621625
++ O.txt Syntax.Type.annotation_separator
622626
++ type_expr typ
627+
++ Modalities.format modalities
623628
++ O.txt Syntax.Type.Record.field_separator)
624-
(* ] *)
625629
in
626630
(url, attrs, cell)
627631
in
@@ -630,7 +634,9 @@ module Make (Syntax : SYNTAX) = struct
630634
|> List.map (fun fld ->
631635
let open Odoc_model.Lang.TypeDecl.Field in
632636
let url, attrs, code =
633-
field fld.mutable_ (fld.id :> Paths.Identifier.t) fld.type_
637+
field fld.mutable_
638+
(fld.id :> Paths.Identifier.t)
639+
fld.type_ fld.modalities
634640
in
635641
let anchor = Some url in
636642
let doc = fld.doc.elements in
@@ -708,7 +714,9 @@ module Make (Syntax : SYNTAX) = struct
708714
| Tuple lst ->
709715
let params =
710716
O.list lst ~sep:Syntax.Type.Tuple.element_separator
711-
~f:(type_expr ~needs_parentheses:is_gadt)
717+
~f:(fun (te, mods) ->
718+
type_expr ~needs_parentheses:is_gadt te
719+
++ Modalities.format mods)
712720
in
713721
O.documentedSrc
714722
(cstr
@@ -1058,6 +1066,7 @@ module Make (Syntax : SYNTAX) = struct
10581066
++ O.txt " " ++ O.txt name
10591067
++ O.txt Syntax.Type.annotation_separator
10601068
++ O.cut ++ type_expr t.type_
1069+
++ Modalities.format t.modalities
10611070
++ if semicolon then O.txt ";" else O.noop)
10621071
in
10631072
let attr = [ "value" ] @ extra_attr in

‎src/loader/cmi.ml‎

Lines changed: 40 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -539,6 +539,19 @@ let jkind_of_type_desc te =
539539
| Tvar { jkind; _ } | Tunivar { jkind; _ } ->
540540
read_jkind_annotation jkind.annotation
541541
| _ -> Kind.Default
542+
543+
let read_modalities mut modalities =
544+
Typemode.least_modalities ~include_implied:false ~mut modalities
545+
|> Typemode.sort_dedup_modalities
546+
|> List.map (fun (Mode.Modality.Atom (ax, m)) ->
547+
Format_doc.asprintf "%a" (Mode.Modality.Per_axis.print ax) m)
548+
549+
let read_value_modalities modalities =
550+
let const =
551+
Ctype.zap_modalities_to_floor_if_modes_enabled_at Alpha modalities
552+
in
553+
read_modalities Immutable const
554+
542555
#else
543556

544557
let jkind_of_type_desc _te = Kind.Default
@@ -808,7 +821,14 @@ let read_value_description ({ident_env ; warnings_tag} as env) parent id vd =
808821
External primitives
809822
| _ -> assert false
810823
in
811-
Value { Value.id; source_loc; doc; type_; value }
824+
let modalities =
825+
#if defined OXCAML
826+
read_value_modalities vd.val_modalities
827+
#else
828+
[]
829+
#endif
830+
in
831+
Value { Value.id; source_loc; doc; type_; value; modalities }
812832

813833
#if defined OXCAML
814834
let is_mutable = Types.is_mutable
@@ -826,21 +846,36 @@ let read_label_declaration env parent ld =
826846
in
827847
let mutable_ = is_mutable ld.ld_mutable in
828848
let type_ = read_type_expr env ld.ld_type in
829-
{id; doc; mutable_; type_}
849+
let modalities =
850+
#if defined OXCAML
851+
read_modalities ld.ld_mutable ld.ld_modalities
852+
#else
853+
[]
854+
#endif
855+
in
856+
{id; doc; mutable_; type_; modalities}
830857

831858
let read_constructor_declaration_arguments env parent arg =
832859
#if OCAML_VERSION < (4,3,0)
833860
(* NOTE(@ostera): constructor with inlined records were introduced post 4.02
834861
so it's safe to use Tuple here *)
835862
ignore parent;
836-
TypeDecl.Constructor.Tuple(List.map (read_type_expr env) arg)
863+
TypeDecl.Constructor.Tuple(List.map (fun x -> read_type_expr env x, []) arg)
837864
#else
838865
let open TypeDecl.Constructor in
839866
match arg with
840867
#if defined OXCAML
841-
| Cstr_tuple args -> Tuple (List.map (fun arg -> read_type_expr env arg.ca_type) args)
868+
| Cstr_tuple args ->
869+
let args_with_modalities =
870+
List.map
871+
(fun arg ->
872+
read_type_expr env arg.ca_type,
873+
read_modalities Immutable arg.ca_modalities)
874+
args
875+
in
876+
Tuple args_with_modalities
842877
#else
843-
| Cstr_tuple args -> Tuple (List.map (read_type_expr env) args)
878+
| Cstr_tuple args -> Tuple (List.map (fun arg -> read_type_expr env arg, []) args)
844879
#endif
845880
| Cstr_record lds ->
846881
Record (List.map (read_label_declaration env parent) lds)

‎src/loader/cmi.mli‎

Lines changed: 9 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -101,4 +101,13 @@ val read_exception : env ->
101101
val read_jkind_annotation :
102102
Parsetree.jkind_annotation option ->
103103
Odoc_model.Lang.Kind.t
104+
105+
val read_modalities :
106+
Types.mutability ->
107+
Mode.Modality.Const.t ->
108+
Odoc_model.Lang.Modalities.t
109+
110+
val read_value_modalities :
111+
Mode.Modality.t ->
112+
Odoc_model.Lang.Modalities.t
104113
#endif

‎src/loader/cmt.ml‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -53,7 +53,7 @@ let rec read_pattern env parent doc pat =
5353
Cmi.mark_type_expr pat.pat_type;
5454
let type_ = Cmi.read_type_expr env pat.pat_type in
5555
let value = Abstract in
56-
[Value {id; source_loc; doc; type_; value}]
56+
[Value {id; source_loc; doc; type_; value; modalities = []}]
5757
#if OCAML_VERSION < (5,2, 0)
5858
| Tpat_alias(pat, id, _) ->
5959
#elif defined OXCAML
@@ -68,7 +68,7 @@ let rec read_pattern env parent doc pat =
6868
Cmi.mark_type_expr pat.pat_type;
6969
let type_ = Cmi.read_type_expr env pat.pat_type in
7070
let value = Abstract in
71-
Value {id; source_loc; doc; type_; value} :: read_pattern env parent doc pat
71+
Value {id; source_loc; doc; type_; value; modalities = []} :: read_pattern env parent doc pat
7272
| Tpat_constant _ -> []
7373
| Tpat_tuple pats ->
7474
#if OCAML_VERSION >= (5, 4, 0) || defined OXCAML

‎src/loader/cmti.ml‎

Lines changed: 37 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -239,7 +239,14 @@ let read_value_description env parent vd =
239239
| [] -> Value.Abstract
240240
| primitives -> External primitives
241241
in
242-
Value { Value.id; source_loc; doc; type_; value }
242+
let modalities =
243+
#if defined OXCAML
244+
Cmi.read_value_modalities vd.val_val.val_modalities
245+
#else
246+
[]
247+
#endif
248+
in
249+
Value { Value.id; source_loc; doc; type_; value; modalities }
243250

244251
let read_type_parameter (ctyp, var_and_injectivity) =
245252
let open TypeDecl in
@@ -293,7 +300,14 @@ let read_label_declaration env parent label_parent ld =
293300
let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_parent ld.ld_attributes in
294301
let mutable_ = is_mutable ld.ld_mutable in
295302
let type_ = read_core_type env label_parent ld.ld_type in
296-
{id; doc; mutable_; type_}
303+
let modalities =
304+
#if defined OXCAML
305+
Cmi.read_modalities ld.ld_mutable ld.ld_modalities.moda_modalities
306+
#else
307+
[]
308+
#endif
309+
in
310+
{id; doc; mutable_; type_; modalities}
297311

298312
let read_unboxed_label_declaration env parent label_parent ld =
299313
let open TypeDecl.UnboxedField in
@@ -309,14 +323,21 @@ let read_constructor_declaration_arguments env parent label_parent arg =
309323
let open TypeDecl.Constructor in
310324
#if OCAML_VERSION < (4,3,0)
311325
ignore parent;
312-
Tuple (List.map (read_core_type env label_parent) arg)
326+
Tuple (List.map (fun x -> read_core_type env label_parent x, []) arg)
313327
#else
314328
match arg with
315329
| Cstr_tuple args ->
316330
#if defined OXCAML
317-
Tuple (List.map (fun arg -> read_core_type env label_parent arg.ca_type) args)
331+
let args_with_modalities =
332+
List.map
333+
(fun arg ->
334+
read_core_type env label_parent arg.ca_type,
335+
Cmi.read_modalities Immutable arg.ca_modalities.moda_modalities)
336+
args
337+
in
338+
Tuple args_with_modalities
318339
#else
319-
Tuple (List.map (fun arg -> read_core_type env label_parent arg) args)
340+
Tuple (List.map (fun arg -> read_core_type env label_parent arg, []) args)
320341
#endif
321342
| Cstr_record lds ->
322343
Record (List.map (read_label_declaration env parent label_parent) lds)
@@ -645,7 +666,17 @@ let rec read_with_constraint env global_parent parent (_, frag, constr) =
645666
and read_module_type env parent label_parent mty =
646667
let open ModuleType in
647668
match mty.mty_desc with
648-
| Tmty_ident(p, _) -> Path { p_path = Env.Path.read_module_type env.ident_env p; p_expansion = None }
669+
| Tmty_ident(p, _) ->
670+
(match mty.mty_type with
671+
#if defined OXCAML
672+
| Mty_signature sg ->
673+
(* For modules with modalities (e.g. [module M : S @@ portable]),
674+
the mty_desc stores only [Tmty_ident S] so we use the mty_type
675+
for the expanded signature with modalities applied to each value. *)
676+
let mty_type = Odoc_model.Compat.module_type mty.mty_type in
677+
Cmi.read_module_type env parent mty_type
678+
#endif
679+
| _ -> Path { p_path = Env.Path.read_module_type env.ident_env p; p_expansion = None })
649680
| Tmty_signature sg ->
650681
let sg, () = read_signature Odoc_model.Semantics.Expect_none env parent sg in
651682
Signature sg

‎src/model/lang.ml‎

Lines changed: 11 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -212,13 +212,19 @@ end =
212212

213213
(** {3 Type Declarations} *)
214214

215+
and Modalities : sig
216+
type t = string list
217+
end =
218+
Modalities
219+
215220
and TypeDecl : sig
216221
module Field : sig
217222
type t = {
218223
id : Identifier.Field.t;
219224
doc : Comment.docs;
220225
mutable_ : bool;
221226
type_ : TypeExpr.t;
227+
modalities : Modalities.t;
222228
}
223229
end
224230

@@ -232,7 +238,9 @@ and TypeDecl : sig
232238
end
233239

234240
module Constructor : sig
235-
type argument = Tuple of TypeExpr.t list | Record of Field.t list
241+
type argument =
242+
| Tuple of (TypeExpr.t * Modalities.t) list
243+
| Record of Field.t list
236244

237245
type t = {
238246
id : Identifier.Constructor.t;
@@ -329,6 +337,7 @@ and Value : sig
329337
value : value;
330338
doc : Comment.docs;
331339
type_ : TypeExpr.t;
340+
modalities : Modalities.t;
332341
}
333342
end =
334343
Value
@@ -426,7 +435,7 @@ and Kind : sig
426435
| Default
427436
| Abbreviation of Fragment.Type.t
428437
| Mod of t * string list
429-
| With of t * TypeExpr.t * string list
438+
| With of t * TypeExpr.t * Modalities.t
430439
| Kind_of of TypeExpr.t
431440
| Product of t list
432441
end =

‎src/model_desc/lang_desc.ml‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -323,6 +323,7 @@ and typedecl_field =
323323
F ("doc", (fun t -> t.doc), docs);
324324
F ("mutable_", (fun t -> t.mutable_), bool);
325325
F ("type_", (fun t -> t.type_), typeexpr_t);
326+
F ("modalities", (fun t -> t.modalities), List string);
326327
]
327328

328329
and typedecl_unboxed_field =
@@ -339,7 +340,7 @@ and typedecl_constructor_argument =
339340
let open Lang.TypeDecl.Constructor in
340341
T.Variant
341342
(function
342-
| Tuple x -> C ("Tuple", x, List typeexpr_t)
343+
| Tuple x -> C ("Tuple", x, List (Pair (typeexpr_t, List string)))
343344
| Record x -> C ("Record", x, List typedecl_field))
344345

345346
and typedecl_constructor =
@@ -477,6 +478,7 @@ and value_t =
477478
F ("doc", (fun t -> t.doc), docs);
478479
F ("type_", (fun t -> t.type_), typeexpr_t);
479480
F ("value", (fun t -> t.value), value_value_t);
481+
F ("modalities", (fun t -> t.modalities), List string);
480482
]
481483

482484
(** {3 Class} *)

‎src/search/html.ml‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -34,10 +34,10 @@ let display_constructor_args args =
3434
let open Odoc_model.Lang in
3535
match args with
3636
| TypeDecl.Constructor.Tuple args ->
37-
let no_label arg = (None, arg) in
37+
let no_label (arg, _mods) = (None, arg) in
3838
(match args with
3939
| _ :: _ :: _ -> Some TypeExpr.(Tuple (List.map no_label args))
40-
| [ arg ] -> Some arg
40+
| [ (arg, _) ] -> Some arg
4141
| _ -> None)
4242
|> map_option Text.of_type
4343
| TypeDecl.Constructor.Record fields -> Some (Text.of_record fields)

‎src/search/json_index/json_search.ml‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -7,7 +7,9 @@ let json_of_args (args : Odoc_model.Lang.TypeDecl.Constructor.argument) =
77
`Object
88
[
99
("kind", `String "Tuple");
10-
("vals", `Array (List.map (fun te -> `String (Text.of_type te)) tel));
10+
( "vals",
11+
`Array (List.map (fun (te, _mods) -> `String (Text.of_type te)) tel)
12+
);
1113
]
1214
| Record fl ->
1315
`Object
@@ -21,6 +23,7 @@ let json_of_args (args : Odoc_model.Lang.TypeDecl.Constructor.argument) =
2123
mutable_;
2224
type_;
2325
doc = _;
26+
modalities = _;
2427
} ->
2528
`Object
2629
[

0 commit comments

Comments
 (0)