Skip to content

Commit 9a4cbc9

Browse files
panglesdpanglesd
committed
Frontmatter: add support for @short_title 
1 parent beb6fd3 commit 9a4cbc9

File tree

17 files changed

+239
-67
lines changed

17 files changed

+239
-67
lines changed

‎src/model/frontmatter.ml‎

Lines changed: 41 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -1,21 +1,41 @@
11
type child = Page of string | Dir of string
22

3-
type line = Children_order of child Location_.with_location list
3+
type short_title = Comment.link_content
4+
5+
type line =
6+
| Children_order of child Location_.with_location list
7+
| Short_title of short_title
48

59
type children_order = child Location_.with_location list Location_.with_location
610

7-
type t = { children_order : children_order option }
11+
type t = {
12+
children_order : children_order option;
13+
short_title : short_title option;
14+
}
15+
16+
let empty = { children_order = None; short_title = None }
817

9-
let empty = { children_order = None }
18+
let update ~tag_name ~loc v new_v =
19+
match v with
20+
| None -> Some new_v
21+
| Some _ ->
22+
Error.raise_warning (Error.make "Duplicated @%s entry" tag_name loc);
23+
v
1024

1125
let apply fm line =
12-
match (line.Location_.value, fm) with
13-
| Children_order children_order, { children_order = None } ->
14-
{ children_order = Some (Location_.same line children_order) }
15-
| Children_order _, { children_order = Some _ } ->
16-
Error.raise_warning
17-
(Error.make "Duplicated @children_order entry" line.location);
18-
fm
26+
match line.Location_.value with
27+
| Short_title t ->
28+
let short_title =
29+
update ~tag_name:"short_title" ~loc:line.location fm.short_title t
30+
in
31+
{ fm with short_title }
32+
| Children_order children_order ->
33+
let children_order = Location_.same line children_order in
34+
let children_order =
35+
update ~tag_name:"children_order" ~loc:line.location fm.children_order
36+
children_order
37+
in
38+
{ fm with children_order }
1939

2040
let parse_child c =
2141
if Astring.String.is_suffix ~affix:"/" c then
@@ -29,7 +49,7 @@ let parse_children_order loc co =
2949
| [] -> Result.Ok (Location_.at loc (Children_order (List.rev acc)))
3050
| ({ Location_.value = `Word word; _ } as w) :: tl ->
3151
parse_words ({ w with value = parse_child word } :: acc) tl
32-
| { Location_.value = `Space _; _ } :: tl -> parse_words acc tl
52+
| { Location_.value = `Space; _ } :: tl -> parse_words acc tl
3353
| { location; _ } :: _ ->
3454
Error
3555
(Error.make "Only words are accepted when specifying children order"
@@ -41,5 +61,15 @@ let parse_children_order loc co =
4161
Error
4262
(Error.make "Only words are accepted when specifying children order" loc)
4363

64+
let parse_short_title loc t =
65+
match t with
66+
| [ { Location_.value = `Paragraph words; _ } ] ->
67+
let short_title = Comment.link_content_of_inline_elements words in
68+
Result.Ok (Location_.at loc (Short_title short_title))
69+
| _ ->
70+
Error
71+
(Error.make
72+
"Short titles cannot contain other block than a single paragraph" loc)
73+
4474
let of_lines lines =
4575
Error.catch_warnings @@ fun () -> List.fold_left apply empty lines

‎src/model/frontmatter.mli‎

Lines changed: 12 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,26 @@
11
type child = Page of string | Dir of string
22

3+
type short_title = Comment.link_content
4+
35
type line
46

57
type children_order = child Location_.with_location list Location_.with_location
68

7-
type t = { children_order : children_order option }
9+
type t = {
10+
children_order : children_order option;
11+
short_title : short_title option;
12+
}
813

914
val empty : t
1015

1116
val parse_children_order :
1217
Location_.span ->
13-
Odoc_parser.Ast.nestable_block_element Location_.with_location list ->
18+
Comment.nestable_block_element Location_.with_location list ->
19+
(line Location_.with_location, Error.t) Result.result
20+
21+
val parse_short_title :
22+
Location_.span ->
23+
Comment.nestable_block_element Location_.with_location list ->
1424
(line Location_.with_location, Error.t) Result.result
1525

1626
val of_lines : line Location_.with_location list -> t Error.with_warnings

‎src/model/semantics.ml‎

Lines changed: 64 additions & 46 deletions
Original file line numberDiff line numberDiff line change
@@ -25,6 +25,7 @@ let describe_internal_tag = function
2525
| `Closed -> "@closed"
2626
| `Hidden -> "@hidden"
2727
| `Children_order _ -> "@children_order"
28+
| `Short_title _ -> "@short_title"
2829

2930
let warn_unexpected_tag { Location.value; location } =
3031
Error.raise_warning
@@ -54,48 +55,6 @@ let rec find_tags acc ~filter = function
5455
warn_unexpected_tag hd;
5556
find_tags acc ~filter tl)
5657

57-
let handle_internal_tags (type a) tags : a handle_internal_tags -> a = function
58-
| Expect_status -> (
59-
match
60-
find_tag
61-
~filter:(function
62-
| (`Inline | `Open | `Closed) as t -> Some t | _ -> None)
63-
tags
64-
with
65-
| Some (status, _) -> status
66-
| None -> `Default)
67-
| Expect_canonical -> (
68-
match
69-
find_tag ~filter:(function `Canonical p -> Some p | _ -> None) tags
70-
with
71-
| Some (`Root _, location) ->
72-
warn_root_canonical location;
73-
None
74-
| Some ((`Dot _ as p), _) -> Some p
75-
| None -> None)
76-
| Expect_page_tags ->
77-
let unparsed_lines =
78-
find_tags []
79-
~filter:(function `Children_order _ as p -> Some p | _ -> None)
80-
tags
81-
in
82-
let lines =
83-
List.filter_map
84-
(function
85-
| `Children_order co, loc -> (
86-
match Frontmatter.parse_children_order loc co with
87-
| Ok co -> Some co
88-
| Error e ->
89-
Error.raise_warning e;
90-
None))
91-
unparsed_lines
92-
in
93-
Frontmatter.of_lines lines |> Error.raise_warnings
94-
| Expect_none ->
95-
(* Will raise warnings. *)
96-
ignore (find_tag ~filter:(fun _ -> None) tags);
97-
()
98-
9958
(* Errors *)
10059
let invalid_raw_markup_target : string -> Location.span -> Error.t =
10160
Error.make ~suggestion:"try '{%html:...%}'."
@@ -138,6 +97,7 @@ let describe_element = function
13897
| `Link (_, _) -> "'{{:...} ...}' (external link)"
13998
| `Heading (level, _, _) ->
14099
Printf.sprintf "'{%i ...}' (section heading)" level
100+
| `Specific s -> s
141101

142102
(* End of errors *)
143103

@@ -188,7 +148,8 @@ type surrounding =
188148
| `Reference of
189149
[ `Simple | `With_text ]
190150
* string Location_.with_location
191-
* Odoc_parser.Ast.inline_element Location_.with_location list ]
151+
* Odoc_parser.Ast.inline_element Location_.with_location list
152+
| `Specific of string ]
192153

193154
let rec non_link_inline_element :
194155
surrounding:surrounding ->
@@ -524,12 +485,13 @@ let strip_internal_tags ast : internal_tags_removed with_location list * _ =
524485
in
525486
match tag with
526487
| (`Inline | `Open | `Closed | `Hidden) as tag -> next tag
527-
| `Children_order co ->
488+
| (`Children_order _ | `Short_title _) as tag ->
489+
let tag_name = describe_internal_tag tag in
528490
if not start then
529491
Error.raise_warning
530-
(Error.make "@children_order tag has to be before any content"
492+
(Error.make "%s tag has to be before any content" tag_name
531493
wloc.location);
532-
next (`Children_order co)
494+
next tag
533495
| `Canonical { Location.value = s; location = r_location } -> (
534496
match
535497
Error.raise_warnings (Reference.read_path_longident r_location s)
@@ -568,6 +530,54 @@ let append_alerts_to_comment alerts
568530
in
569531
comment @ (alerts : alerts :> Comment.docs)
570532

533+
let handle_internal_tags (type a) tags : a handle_internal_tags -> a = function
534+
| Expect_status -> (
535+
match
536+
find_tag
537+
~filter:(function
538+
| (`Inline | `Open | `Closed) as t -> Some t | _ -> None)
539+
tags
540+
with
541+
| Some (status, _) -> status
542+
| None -> `Default)
543+
| Expect_canonical -> (
544+
match
545+
find_tag ~filter:(function `Canonical p -> Some p | _ -> None) tags
546+
with
547+
| Some (`Root _, location) ->
548+
warn_root_canonical location;
549+
None
550+
| Some ((`Dot _ as p), _) -> Some p
551+
| None -> None)
552+
| Expect_page_tags ->
553+
let unparsed_lines =
554+
find_tags []
555+
~filter:(function
556+
| (`Children_order _ | `Short_title _) as p -> Some p | _ -> None)
557+
tags
558+
in
559+
let lines =
560+
let do_ parse loc els =
561+
let els = nestable_block_elements els in
562+
match parse loc els with
563+
| Ok res -> Some res
564+
| Error e ->
565+
Error.raise_warning e;
566+
None
567+
in
568+
List.filter_map
569+
(function
570+
| `Children_order co, loc ->
571+
do_ Frontmatter.parse_children_order loc co
572+
| `Short_title t, loc -> do_ Frontmatter.parse_short_title loc t)
573+
unparsed_lines
574+
in
575+
Frontmatter.of_lines lines |> Error.raise_warnings
576+
| Expect_none ->
577+
(* Will raise warnings. *)
578+
ignore (find_tag ~filter:(fun _ -> None) tags);
579+
()
580+
571581
let ast_to_comment ~internal_tags ~tags_allowed ~parent_of_sections
572582
(ast : Ast.t) alerts =
573583
Error.catch_warnings (fun () ->
@@ -598,3 +608,11 @@ let parse_reference text =
598608
}
599609
in
600610
Reference.parse location text
611+
612+
let non_link_inline_element :
613+
context:string ->
614+
Odoc_parser.Ast.inline_element with_location list ->
615+
Comment.non_link_inline_element with_location list =
616+
fun ~context elements ->
617+
let surrounding = `Specific context in
618+
non_link_inline_elements ~surrounding elements

‎src/model/semantics.mli‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -19,6 +19,11 @@ val ast_to_comment :
1919
alerts ->
2020
(Comment.docs * 'tags) Error.with_warnings
2121

22+
val non_link_inline_element :
23+
context:string ->
24+
Odoc_parser.Ast.inline_element Location_.with_location list ->
25+
Comment.non_link_inline_element Location_.with_location list
26+
2227
val parse_comment :
2328
internal_tags:'tags handle_internal_tags ->
2429
tags_allowed:bool ->

‎src/model_desc/comment_desc.ml‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -187,3 +187,11 @@ let docs = Indirect ((fun n -> ((n :> docs) :> general_docs)), docs)
187187

188188
let docs_or_stop : docs_or_stop t =
189189
Variant (function `Docs x -> C ("`Docs", x, docs) | `Stop -> C0 "`Stop")
190+
191+
let inline_element : inline_element Location_.with_location list Type_desc.t =
192+
List
193+
(Indirect
194+
( (fun x ->
195+
let x :> general_inline_element Location_.with_location = x in
196+
ignore_loc x),
197+
inline_element ))

‎src/model_desc/comment_desc.mli‎

Lines changed: 7 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,8 @@
1-
val docs : Odoc_model.Comment.docs Type_desc.t
1+
open Odoc_model
2+
open Odoc_model.Comment
23

3-
val docs_or_stop : Odoc_model.Comment.docs_or_stop Type_desc.t
4+
val docs : docs Type_desc.t
5+
6+
val inline_element : inline_element Location_.with_location list Type_desc.t
7+
8+
val docs_or_stop : docs_or_stop Type_desc.t

‎src/model_desc/lang_desc.ml‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -712,6 +712,12 @@ and frontmatter =
712712
( "children",
713713
(fun t -> Option.map ignore_loc t.children_order),
714714
Option (List child) );
715+
F
716+
( "short_title",
717+
(fun t ->
718+
(t.short_title
719+
:> Comment.inline_element Location_.with_location list option)),
720+
Option Comment_desc.inline_element );
715721
]
716722

717723
and child =

‎src/odoc/compile.ml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -207,7 +207,7 @@ let is_index_page = function
207207
| { iv = `LeafPage (_, p); _ } ->
208208
String.equal (Names.PageName.to_string p) "index"
209209

210-
let has_children_order { Frontmatter.children_order } =
210+
let has_children_order { Frontmatter.children_order; _ } =
211211
Option.is_some children_order
212212

213213
let mld ~parent_id ~parents_children ~output ~children ~warnings_options input =

‎src/parser/ast.ml‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -77,7 +77,9 @@ type internal_tag =
7777
| `Open
7878
| `Closed
7979
| `Hidden
80-
| `Children_order of nestable_block_element with_location list ]
80+
| `Children_order of nestable_block_element with_location list
81+
| `Short_title of nestable_block_element with_location list ]
82+
8183
(** Internal tags are used to exercise fine control over the output of odoc. They
8284
are never rendered in the output *)
8385

‎src/parser/lexer.mll‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -543,6 +543,9 @@ and token input = parse
543543
| ("@children_order")
544544
{ emit input (`Tag `Children_order) }
545545

546+
| ("@short_title")
547+
{ emit input (`Tag `Short_title) }
548+
546549
| "@see" horizontal_space* '<' ([^ '>']* as url) '>'
547550
{ emit input (`Tag (`See (`Url, url))) }
548551

0 commit comments

Comments
 (0)