Skip to content

Commit 111eb88

Browse files
panglesdpanglesd
committed
Frontmatter: add support for @short_title 
1 parent 3337013 commit 111eb88

File tree

17 files changed

+236
-64
lines changed

17 files changed

+236
-64
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: 61 additions & 43 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,45 +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-
(function (`Inline | `Open | `Closed) as t -> Some t | _ -> None)
62-
tags
63-
with
64-
| Some (status, _) -> status
65-
| None -> `Default)
66-
| Expect_canonical -> (
67-
match find_tag (function `Canonical p -> Some p | _ -> None) tags with
68-
| Some (`Root _, location) ->
69-
warn_root_canonical location;
70-
None
71-
| Some ((`Dot _ as p), _) -> Some p
72-
| None -> None)
73-
| Expect_page_tags ->
74-
let unparsed_lines =
75-
find_tags []
76-
~filter:(function `Children_order _ as p -> Some p | _ -> None)
77-
tags
78-
in
79-
let lines =
80-
List.filter_map
81-
(function
82-
| `Children_order co, loc -> (
83-
match Frontmatter.parse_children_order loc co with
84-
| Ok co -> Some co
85-
| Error e ->
86-
Error.raise_warning e;
87-
None))
88-
unparsed_lines
89-
in
90-
Frontmatter.of_lines lines |> Error.raise_warnings
91-
| Expect_none ->
92-
(* Will raise warnings. *)
93-
ignore (find_tag (fun _ -> None) tags);
94-
()
95-
9658
(* Errors *)
9759
let invalid_raw_markup_target : string -> Location.span -> Error.t =
9860
Error.make ~suggestion:"try '{%html:...%}'."
@@ -135,6 +97,7 @@ let describe_element = function
13597
| `Link (_, _) -> "'{{:...} ...}' (external link)"
13698
| `Heading (level, _, _) ->
13799
Printf.sprintf "'{%i ...}' (section heading)" level
100+
| `Specific s -> s
138101

139102
(* End of errors *)
140103

@@ -185,7 +148,8 @@ type surrounding =
185148
| `Reference of
186149
[ `Simple | `With_text ]
187150
* string Location_.with_location
188-
* Odoc_parser.Ast.inline_element Location_.with_location list ]
151+
* Odoc_parser.Ast.inline_element Location_.with_location list
152+
| `Specific of string ]
189153

190154
let rec non_link_inline_element :
191155
surrounding:surrounding ->
@@ -521,12 +485,13 @@ let strip_internal_tags ast : internal_tags_removed with_location list * _ =
521485
in
522486
match tag with
523487
| (`Inline | `Open | `Closed | `Hidden) as tag -> next tag
524-
| `Children_order co ->
488+
| (`Children_order _ | `Short_title _) as tag ->
489+
let tag_name = describe_internal_tag tag in
525490
if not start then
526491
Error.raise_warning
527-
(Error.make "@children_order tag has to be before any content"
492+
(Error.make "%s tag has to be before any content" tag_name
528493
wloc.location);
529-
next (`Children_order co)
494+
next tag
530495
| `Canonical { Location.value = s; location = r_location } -> (
531496
match
532497
Error.raise_warnings (Reference.read_path_longident r_location s)
@@ -565,6 +530,51 @@ let append_alerts_to_comment alerts
565530
in
566531
comment @ (alerts : alerts :> Comment.docs)
567532

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