From da7472710113b348e4d154dd0150ce001e6972f1 Mon Sep 17 00:00:00 2001 From: favonia Date: Wed, 8 Jun 2022 08:17:29 -0500 Subject: [PATCH 1/2] Augment Inline.t with the information about being preformatted --- src/document/types.ml | 34 ++++++++++++++++++++++++++++++++-- 1 file changed, 32 insertions(+), 2 deletions(-) diff --git a/src/document/types.ml b/src/document/types.ml index 154a81062a..c95c64423f 100644 --- a/src/document/types.ml +++ b/src/document/types.ml @@ -35,9 +35,11 @@ and Inline : sig type href = string + type preformatted = { begin_ : bool; end_ : bool } + type t = one list - and one = { attr : Class.t; desc : desc } + and one = { attr : Class.t; preformatted : preformatted; desc : desc } and desc = | Text of string @@ -159,6 +161,34 @@ and Page : sig end = Page -let inline ?(attr = []) desc = Inline.{ attr; desc } +let rec last = function + | [] -> invalid_arg "last" + | [ x ] -> x + | _ :: xs -> last xs + +let rec is_inline_preformatted = + let open Inline in + function + | Text _ | Linebreak -> { begin_ = false; end_ = false } + | Entity _ | Source _ -> { begin_ = true; end_ = true } + | Styled (_, is) | Link (_, is) -> is_inline_list_preformatted is + | InternalLink il -> is_internallink_preformatted il + (* Ideally, the markup should be parsed *) + | Raw_markup _ -> { begin_ = false; end_ = false } + +and is_inline_list_preformatted = function + | [] -> { begin_ = false; end_ = false } + | l -> + { + begin_ = (List.hd l).preformatted.begin_; + end_ = (last l).preformatted.end_; + } + +and is_internallink_preformatted = function + | Resolved (_, is) | Unresolved is -> is_inline_list_preformatted is + +let inline ?(attr = []) desc = + let preformatted = is_inline_preformatted desc in + Inline.{ attr; preformatted; desc } let block ?(attr = []) desc = Block.{ attr; desc } From 56fdef1eab5bdd02abbf8f6cbacb12cedd4f31e2 Mon Sep 17 00:00:00 2001 From: favonia Date: Wed, 8 Jun 2022 08:33:45 -0500 Subject: [PATCH 2/2] Update the HTML generator --- src/document/types.ml | 3 + src/html/generator.ml | 103 +++++++++++++----- src/odoc/etc/odoc.css | 14 +++ test/generators/cases/markup.mli | 5 +- test/generators/html/Markup.html | 10 +- test/generators/html/Ocamlary.html | 43 +++++--- .../html/Recent-module-type-PolyS.html | 10 +- test/generators/html/Recent.html | 15 ++- test/generators/html/Type.html | 32 +++--- test/generators/latex/Markup.tex | 2 +- test/generators/man/Markup.3o | 2 +- 11 files changed, 163 insertions(+), 76 deletions(-) diff --git a/src/document/types.ml b/src/document/types.ml index c95c64423f..b82e59fb58 100644 --- a/src/document/types.ml +++ b/src/document/types.ml @@ -166,6 +166,9 @@ let rec last = function | [ x ] -> x | _ :: xs -> last xs +(* Checking whether an Inline.desc starts with or ends with preformatted text. + This is only an approximation as we did not check whether the text is empty + [Text ""] or the styled inline is empty [Style (_, [])]. *) let rec is_inline_preformatted = let open Inline in function diff --git a/src/html/generator.ml b/src/html/generator.ml index 73c1cda5e5..f68a48be04 100644 --- a/src/html/generator.ml +++ b/src/html/generator.ml @@ -28,6 +28,28 @@ type phrasing = Html_types.phrasing type non_link_phrasing = Html_types.phrasing_without_interactive +type context = { following_code : bool; followed_by_code : bool } + +let default_context = { following_code = false; followed_by_code = false } + +let rec inline_list_concat_map ~context ~f = function + | [] -> [] + | [ x ] -> f ~context x + | x1 :: (x2 :: _ as xs) -> + let hd = + let context = + { context with followed_by_code = x2.Inline.preformatted.begin_ } + in + f ~context x1 + in + let tl = + let context = + { context with following_code = x1.Inline.preformatted.end_ } + in + inline_list_concat_map ~context ~f xs + in + hd @ tl + let mk_anchor_link id = [ Html.a ~a:[ Html.a_href ("#" ^ id); Html.a_class [ "anchor" ] ] [] ] @@ -42,6 +64,14 @@ let mk_anchor anchor = let class_ (l : Class.t) = if l = [] then [] else [ Html.a_class l ] +let class_with_context ~context (l : Class.t) = + class_ @@ l + @ List.concat + [ + (if context.following_code then [ "following-code" ] else []); + (if context.followed_by_code then [ "followed-by-code" ] else []); + ] + and raw_markup (t : Raw_markup.t) = let target, content = t in match Astring.String.Ascii.lowercase target with @@ -74,13 +104,15 @@ and styled style ~emph_level = | `Superscript -> (emph_level, Html.sup ~a:[]) | `Subscript -> (emph_level, Html.sub ~a:[]) -let rec internallink ~emph_level ~resolve ?(a = []) (t : InternalLink.t) = +let rec internallink ~context ~emph_level ~resolve ?(a = []) + (t : InternalLink.t) = match t with | Resolved (uri, content) -> let href = Link.href ~resolve uri in let a = (a :> Html_types.a_attrib Html.attrib list) in let elt = - Html.a ~a:(Html.a_href href :: a) (inline_nolink ~emph_level content) + Html.a ~a:(Html.a_href href :: a) + (inline_nolink ~context ~emph_level content) in let elt = (elt :> phrasing Html.elt) in [ elt ] @@ -90,59 +122,66 @@ let rec internallink ~emph_level ~resolve ?(a = []) (t : InternalLink.t) = * (ref_to_string ref) * in *) let a = Html.a_class [ "xref-unresolved" ] :: a in - let elt = Html.span ~a (inline ~emph_level ~resolve content) in + let elt = Html.span ~a (inline ~context ~emph_level ~resolve content) in let elt = (elt :> phrasing Html.elt) in [ elt ] -and internallink_nolink ~emph_level +and internallink_nolink ~context ~emph_level ~(a : Html_types.span_attrib Html.attrib list) (t : InternalLink.t) = match t with | Resolved (_, content) | Unresolved content -> - [ Html.span ~a (inline_nolink ~emph_level content) ] + [ Html.span ~a (inline_nolink ~context ~emph_level content) ] -and inline ?(emph_level = 0) ~resolve (l : Inline.t) : phrasing Html.elt list = - let one (t : Inline.one) = +and inline ~context ?(emph_level = 0) ~resolve (l : Inline.t) : + phrasing Html.elt list = + let one ~context (t : Inline.one) = let a = class_ t.attr in match t.desc with | Text "" -> [] | Text s -> if a = [] then [ Html.txt s ] else [ Html.span ~a [ Html.txt s ] ] | Entity s -> + let a = class_with_context ~context t.attr in if a = [] then [ Html.entity s ] else [ Html.span ~a [ Html.entity s ] ] | Linebreak -> [ Html.br ~a () ] | Styled (style, c) -> let emph_level, app_style = styled style ~emph_level in - [ app_style @@ inline ~emph_level ~resolve c ] + [ app_style @@ inline ~context ~emph_level ~resolve c ] | Link (href, c) -> let a = (a :> Html_types.a_attrib Html.attrib list) in - let content = inline_nolink ~emph_level c in + let content = inline_nolink ~context ~emph_level c in [ Html.a ~a:(Html.a_href href :: a) content ] - | InternalLink c -> internallink ~emph_level ~resolve ~a c - | Source c -> source (inline ~emph_level ~resolve) ~a c + | InternalLink c -> internallink ~context ~emph_level ~resolve ~a c + | Source c -> + let a = class_with_context ~context t.attr in + source (inline ~context:default_context ~emph_level ~resolve) ~a c | Raw_markup r -> raw_markup r in - Utils.list_concat_map ~f:one l + inline_list_concat_map ~context ~f:one l -and inline_nolink ?(emph_level = 0) (l : Inline.t) : +and inline_nolink ~context ?(emph_level = 0) (l : Inline.t) : non_link_phrasing Html.elt list = - let one (t : Inline.one) = + let one ~context (t : Inline.one) = let a = class_ t.attr in match t.desc with | Text "" -> [] | Text s -> if a = [] then [ Html.txt s ] else [ Html.span ~a [ Html.txt s ] ] | Entity s -> + let a = class_with_context ~context t.attr in if a = [] then [ Html.entity s ] else [ Html.span ~a [ Html.entity s ] ] | Linebreak -> [ Html.br ~a () ] | Styled (style, c) -> let emph_level, app_style = styled style ~emph_level in - [ app_style @@ inline_nolink ~emph_level c ] - | Link (_, c) -> inline_nolink ~emph_level c - | InternalLink c -> internallink_nolink ~emph_level ~a c - | Source c -> source (inline_nolink ~emph_level) ~a c + [ app_style @@ inline_nolink ~context ~emph_level c ] + | Link (_, c) -> inline_nolink ~context ~emph_level c + | InternalLink c -> internallink_nolink ~context ~emph_level ~a c + | Source c -> + let a = class_with_context ~context t.attr in + source (inline_nolink ~context:default_context ~emph_level) ~a c | Raw_markup r -> raw_markup r in - Utils.list_concat_map ~f:one l + inline_list_concat_map ~context ~f:one l let heading ~resolve (h : Heading.t) = let a, anchor = @@ -150,7 +189,7 @@ let heading ~resolve (h : Heading.t) = | Some id -> ([ Html.a_id id ], mk_anchor_link id) | None -> ([], []) in - let content = inline ~resolve h.title in + let content = inline ~context:default_context ~resolve h.title in let mk = match h.level with | 0 -> Html.h1 @@ -171,9 +210,11 @@ let rec block ~resolve (l : Block.t) : flow Html.elt list = in match t.desc with | Inline i -> - if t.attr = [] then as_flow @@ inline ~resolve i - else mk_block Html.span (inline ~resolve i) - | Paragraph i -> mk_block Html.p (inline ~resolve i) + if t.attr = [] then + as_flow @@ inline ~context:default_context ~resolve i + else mk_block Html.span (inline ~context:default_context ~resolve i) + | Paragraph i -> + mk_block Html.p (inline ~context:default_context ~resolve i) | List (typ, l) -> let mk = match typ with Ordered -> Html.ol | Unordered -> Html.ul in mk_block mk (List.map (fun x -> Html.li (block ~resolve x)) l) @@ -181,7 +222,7 @@ let rec block ~resolve (l : Block.t) : flow Html.elt list = let item i = let a = class_ i.Description.attr in let term = - (inline ~resolve i.Description.key + (inline ~resolve ~context:default_context i.Description.key : phrasing Html.elt list :> flow Html.elt list) in @@ -195,7 +236,8 @@ let rec block ~resolve (l : Block.t) : flow Html.elt list = let extra_class = match lang_tag with None -> [] | Some lang -> [ "language-" ^ lang ] in - mk_block ~extra_class Html.pre (source (inline ~resolve) c) + mk_block ~extra_class Html.pre + (source (inline ~context:default_context ~resolve) c) in Utils.list_concat_map l ~f:one @@ -241,14 +283,16 @@ let rec documentedSrc ~resolve (t : DocumentedSrc.t) : item Html.elt list = | [] -> [] | (Code _ | Alternative _) :: _ -> let code, _, rest = take_code t in - source (inline ~resolve) code @ to_html rest + source (inline ~context:default_context ~resolve) code @ to_html rest | Subpage subp :: _ -> subpage ~resolve subp | (Documented _ | Nested _) :: _ -> let l, _, rest = take_descr t in let one { DocumentedSrc.attrs; anchor; code; doc; markers } = let content = match code with - | `D code -> (inline ~resolve code :> item Html.elt list) + | `D code -> + (inline ~context:default_context ~resolve code + :> item Html.elt list) | `N n -> to_html n in let doc = @@ -308,7 +352,8 @@ and items ~resolve l : item Html.elt list = let summary = let extra_attr, extra_class, anchor_link = mk_anchor anchor in let a = spec_class (attr @ extra_class) @ extra_attr in - Html.summary ~a @@ anchor_link @ source (inline ~resolve) summary + Html.summary ~a @@ anchor_link + @ source (inline ~context:default_context ~resolve) summary in [ Html.details ~a:open' summary included_html ] in @@ -337,7 +382,7 @@ module Toc = struct let render_toc ~resolve (toc : Toc.t) = let rec section { Toc.url; text; children } = - let text = inline_nolink text in + let text = inline_nolink ~context:default_context text in let text = (text : non_link_phrasing Html.elt list diff --git a/src/odoc/etc/odoc.css b/src/odoc/etc/odoc.css index 4cbbfffcbd..9b9ec18f34 100644 --- a/src/odoc/etc/odoc.css +++ b/src/odoc/etc/odoc.css @@ -387,6 +387,20 @@ li code { padding: 0 0.3ex; } +p code.followed-by-code, +li code.followed-by-code { + border-top-right-radius: 0px; + border-bottom-right-radius: 0px; + padding-right: 0px; +} + +p code.following-code, +li code.following-code { + border-top-left-radius: 0px; + border-bottom-left-radius: 0px; + padding-left: 0px; +} + p a > code { color: var(--link-color); } diff --git a/test/generators/cases/markup.mli b/test/generators/cases/markup.mli index 64d44b0738..aae287f4f8 100644 --- a/test/generators/cases/markup.mli +++ b/test/generators/cases/markup.mli @@ -47,8 +47,9 @@ [code] is a different kind of markup that doesn't allow nested markup. It's possible for two markup elements to appear {b next} {i to} each other - and have a space, and appear {b next}{i to} each other with no space. It - doesn't matter {b how} {i much} space it was in the source: in this + and have a space, and appear {b next}{i to} each other with no space. + This also applies to consecutive code phrases [f][ ][x]. + It doesn't matter {b how} {i much} space it was in the source: in this sentence, it was two space characters. And in this one, there is {b a} {i newline}. diff --git a/test/generators/html/Markup.html b/test/generators/html/Markup.html index 8815b52b24..03591ace03 100644 --- a/test/generators/html/Markup.html +++ b/test/generators/html/Markup.html @@ -88,9 +88,13 @@

It's possible for two markup elements to appear next to each other and have a space, and appear nextto each - other with no space. It doesn't matter how much space - it was in the source: in this sentence, it was two space characters. - And in this one, there is a newline. + other with no space. This also applies to consecutive code phrases + f + + x. It doesn't matter how + much space it was in the source: in this sentence, it was + two space characters. And in this one, there is a newline + .

This is also true between non-code markup and code. diff --git a/test/generators/html/Ocamlary.html b/test/generators/html/Ocamlary.html index a77e59142c..0cf8b8974f 100644 --- a/test/generators/html/Ocamlary.html +++ b/test/generators/html/Ocamlary.html @@ -1040,12 +1040,15 @@

  1. - | `TagA + | + `TagA
  2. - | - `ConstrB of int + | + + `ConstrB of int +
] @@ -1267,13 +1270,15 @@

  1. - | - poly_variant + | + + poly_variant
  2. - | `TagC + | + `TagC
] @@ -1292,8 +1297,8 @@

  1. - | - + | + `TagA of 'a @@ -1314,8 +1319,8 @@

  2. - | - + | + `TagA of 'a @@ -1324,8 +1329,8 @@

  3. - | - + | + `ConstrB of 'b @@ -1445,12 +1450,13 @@

    1. - | `A + | + `A
    2. - | - + | + `B of [ `B1 | `B2 ] @@ -1458,12 +1464,13 @@

    3. - | `C + | + `C
    4. - | - + | + `D of [ `D1 of [ `D1a ] ] diff --git a/test/generators/html/Recent-module-type-PolyS.html b/test/generators/html/Recent-module-type-PolyS.html index 6bee3b33b4..e27df5b826 100644 --- a/test/generators/html/Recent-module-type-PolyS.html +++ b/test/generators/html/Recent-module-type-PolyS.html @@ -23,12 +23,14 @@

      Module type Recent.PolyS
      1. - | - `A + + | + `A
      2. - | - `B + + | + `B
      ] diff --git a/test/generators/html/Recent.html b/test/generators/html/Recent.html index 907983fab5..d647b629b4 100644 --- a/test/generators/html/Recent.html +++ b/test/generators/html/Recent.html @@ -151,23 +151,28 @@

      Module Recent

      1. - | `A + | + `A
      2. - | - `B of int + | + + `B of int +
      3. - | `C + | + `C
        (*

        foo

        *)
      4. - | `D + | + `D
        (*

        bar

        *)
        diff --git a/test/generators/html/Type.html b/test/generators/html/Type.html index 9c5849931a..d86b370533 100644 --- a/test/generators/html/Type.html +++ b/test/generators/html/Type.html @@ -387,22 +387,27 @@

        Module Type

        1. - | `A + | + `A
        2. - | - `B of int + | + + `B of int +
        3. - | - `C of int * unit + | + + `C of int * unit
        4. - | `D + | + `D
        ] @@ -419,8 +424,8 @@

        Module Type

        class="def type anchored"> - | - + | + polymorphic_variant @@ -428,7 +433,8 @@

        Module Type

      5. - | `E + | + `E
      ] @@ -444,8 +450,8 @@

      Module Type

    5. - | - + | + `A of [ `B | `C ] @@ -473,8 +479,8 @@

      Module Type

    6. - | - + | + polymorphic_variant diff --git a/test/generators/latex/Markup.tex b/test/generators/latex/Markup.tex index 34d1abf2f7..f18e888448 100644 --- a/test/generators/latex/Markup.tex +++ b/test/generators/latex/Markup.tex @@ -28,7 +28,7 @@ \subsection{Styling\label{styling}}% \ocamlinlinecode{code} is a different kind of markup that doesn't allow nested markup. -It's possible for two markup elements to appear \bold{next} \emph{to} each other and have a space, and appear \bold{next}\emph{to} each other with no space. It doesn't matter \bold{how} \emph{much} space it was in the source: in this sentence, it was two space characters. And in this one, there is \bold{a} \emph{newline}. +It's possible for two markup elements to appear \bold{next} \emph{to} each other and have a space, and appear \bold{next}\emph{to} each other with no space. This also applies to consecutive code phrases \ocamlinlinecode{f}\ocamlinlinecode{ }\ocamlinlinecode{x}. It doesn't matter \bold{how} \emph{much} space it was in the source: in this sentence, it was two space characters. And in this one, there is \bold{a} \emph{newline}. This is also true between \emph{non-}\ocamlinlinecode{code} markup \emph{and} \ocamlinlinecode{code}. diff --git a/test/generators/man/Markup.3o b/test/generators/man/Markup.3o index f5742f1969..6039cb7746 100644 --- a/test/generators/man/Markup.3o +++ b/test/generators/man/Markup.3o @@ -80,7 +80,7 @@ links in italics with emphasis in emphasis\. .sp code is a different kind of markup that doesn't allow nested markup\. .sp -It's possible for two markup elements to appear \fBnext\fR \fIto\fR each other and have a space, and appear \fBnext\fR\fIto\fR each other with no space\. It doesn't matter \fBhow\fR \fImuch\fR space it was in the source: in this sentence, it was two space characters\. And in this one, there is \fBa\fR \fInewline\fR\. +It's possible for two markup elements to appear \fBnext\fR \fIto\fR each other and have a space, and appear \fBnext\fR\fIto\fR each other with no space\. This also applies to consecutive code phrases f x\. It doesn't matter \fBhow\fR \fImuch\fR space it was in the source: in this sentence, it was two space characters\. And in this one, there is \fBa\fR \fInewline\fR\. .sp This is also true between non-code markup and code\. .sp