diff --git a/src/ast_block.ml b/src/ast_block.ml
index 3ca545d9..8b988968 100644
--- a/src/ast_block.ml
+++ b/src/ast_block.ml
@@ -37,6 +37,8 @@ module Make (C : BlockContent) = struct
; defs : 'attr C.t list
}
+ type 'attr footnote = { id: string; label: string; content: 'attr C.t }
+
(* A value of type 'attr is present in all variants of this type. We use it to associate
extra information to each node in the AST. Cn the common case, the attributes type defined
above is used. We might eventually have an alternative function to parse blocks while keeping
@@ -51,6 +53,7 @@ module Make (C : BlockContent) = struct
| Html_block of 'attr * string
| Definition_list of 'attr * 'attr def_elt list
| Table of 'attr * ('attr C.t * cell_alignment) list * 'attr C.t list list
+ | Footnote_list of 'attr footnote list
(** A table is represented by a header row, which is a list of pairs of
header cells and alignments, and a list of rows *)
end
@@ -79,6 +82,10 @@ module MakeMapper (Src : BlockContent) (Dst : BlockContent) = struct
( attr
, List.map (fun (header, alignment) -> (f header, alignment)) headers
, List.map (List.map f) rows )
+ | Footnote_list footnotes ->
+ Footnote_list
+ (List.map (fun { SrcBlock.id; content; label } -> { DstBlock.id = id; content = f content; label })
+ footnotes)
end
module Mapper = MakeMapper (StringContent) (InlineContent)
diff --git a/src/ast_inline.ml b/src/ast_inline.ml
index a74c8de9..1d68084c 100644
--- a/src/ast_inline.ml
+++ b/src/ast_inline.ml
@@ -16,6 +16,7 @@ type 'attr inline =
| Link of 'attr * 'attr link
| Image of 'attr * 'attr link
| Html of 'attr * string
+ | Sup of 'attr * 'attr inline
and 'attr link =
{ label : 'attr inline
diff --git a/src/html.ml b/src/html.ml
index dd817d34..81ac9a1d 100644
--- a/src/html.ml
+++ b/src/html.ml
@@ -113,7 +113,7 @@ module Identifiers : sig
val empty : t
val touch : string -> t -> int * t
- (** Bump the frequency count for the given string.
+ (** Bump the frequency count for the given string.
It returns the previous count (before bumping) *)
end = struct
module SMap = Map.Make (String)
@@ -169,6 +169,7 @@ let to_plain_text t =
go i
| Hard_break _ | Soft_break _ -> Buffer.add_char buf ' '
| Html _ -> ()
+ | Sup (_, i) -> go i
in
go t;
Buffer.contents buf
@@ -191,6 +192,9 @@ and img label destination title attrs =
in
elt Inline "img" attrs None
+and sup attrs child =
+ elt Inline "sup" attrs (Some child)
+
and inline = function
| Ast.Impl.Concat (_, l) -> concat_map inline l
| Text (_, t) -> text t
@@ -204,6 +208,8 @@ and inline = function
url label destination title attr
| Image (attr, { label; destination; title }) ->
img label destination title attr
+ | Sup (attrs, il) ->
+ sup attrs (inline il)
let alignment_attributes = function
| Default -> []
@@ -249,6 +255,28 @@ let table_body headers rows =
row)))
rows))
+let footnote_block content =
+ elt Block "div" [("class", "footnotes")]
+ (Some (concat
+ (elt Inline "hr" [] None)
+ content))
+
+let footnote_list footnotes =
+ let backlink label =
+ url (Text ([], "↩")) ("#fnref:" ^ label) None [] in
+ let p footnote =
+ (elt
+ Block "p" []
+ (Some
+ (concat
+ (inline footnote.content)
+ (backlink footnote.label))))
+ in
+ elt Block "ol" []
+ (Some (concat_map
+ (fun footnote -> elt Block "li" [("id", footnote.id)] (Some (p footnote)))
+ footnotes))
+
let rec block ~auto_identifiers = function
| Blockquote (attr, q) ->
elt
@@ -310,6 +338,11 @@ let rec block ~auto_identifiers = function
"table"
attr
(Some (concat (table_header headers) (table_body headers rows)))
+ | Footnote_list footnotes -> begin
+ match List.is_empty footnotes with
+ | false -> footnote_block (footnote_list footnotes)
+ | true -> Null
+ end
let of_doc ?(auto_identifiers = true) doc =
let identifiers = Identifiers.empty in
diff --git a/src/omd.ml b/src/omd.ml
index d00f26bf..a1a0dca6 100644
--- a/src/omd.ml
+++ b/src/omd.ml
@@ -15,6 +15,17 @@ let toc = Toc.toc
let parse_inline defs s = Parser.inline defs (Parser.P.of_string s)
+let footnotes defs =
+ let footnote_defs = List.filter_map
+ (fun def -> match def.Parser.kind with
+ | Footnote { id; label; } -> Some ({ id; label; Ast_block.Raw.content = def.destination; })
+ | _ -> None)
+ defs
+ in
+ let footnote_block : _ Ast_block.Raw.block = Footnote_list footnote_defs
+ in
+ footnote_block
+
let parse_inlines (md, defs) : doc =
let defs =
let f (def : attributes Parser.link_def) =
@@ -22,7 +33,8 @@ let parse_inlines (md, defs) : doc =
in
List.map f defs
in
- List.map (Ast_block.Mapper.map (parse_inline defs)) md
+ let blocks = md @ [ (footnotes defs) ] in
+ (List.map (Ast_block.Mapper.map (parse_inline defs)) blocks)
let escape_html_entities = Html.htmlentities
let of_channel ic : doc = parse_inlines (Block_parser.Pre.of_channel ic)
diff --git a/src/parser.ml b/src/parser.ml
index 0723c7a7..fcfbd59b 100644
--- a/src/parser.ml
+++ b/src/parser.ml
@@ -1,10 +1,15 @@
open Ast.Impl
+type link_kind =
+ | Reference
+ | Footnote of { id: string; label: string }
+
type 'attr link_def =
{ label : string
; destination : string
; title : string option
; attributes : 'attr
+ ; kind : link_kind
}
let is_whitespace = function
@@ -1676,7 +1681,7 @@ let rec inline defs st =
let rec reference_link kind acc st =
let off0 = pos st in
match protect (link_label true) st with
- | lab -> (
+ | label -> (
let reflink lab =
let s = normalize lab in
match
@@ -1684,7 +1689,21 @@ let rec inline defs st =
(fun ({ label; _ } : attributes link_def) -> label = s)
defs
with
- | Some { label = _; destination; title; attributes = attr } ->
+ | Some { destination; title; attributes = attr; kind = link_kind; _ } ->
+ (* If reference is footnote, we should remove '^' prefix from the text to display *)
+ let lab = match link_kind with
+ | Footnote { label; _ } -> label
+ | Reference -> lab
+ in
+ (* Printf.sprintf "#fn:%s" reference*)
+ let attr = match link_kind with
+ | Footnote { label; _ } -> ("id", "fnref:" ^ label) :: attr
+ | Reference -> attr
+ in
+ let destination = match link_kind with
+ | Footnote { id; _ } -> "#" ^ id
+ | Reference -> destination
+ in
let lab1 = inline defs (of_string lab) in
let r =
let def = { label = lab1; destination; title } in
@@ -1692,6 +1711,10 @@ let rec inline defs st =
| Pre.Img -> Image (attr, def)
| Url -> Link (attr, def)
in
+ let r = match link_kind with
+ | Footnote { label = _; _ } -> Sup ([], r)
+ | Reference -> r
+ in
loop (Pre.R r :: text acc) st
| None ->
if kind = Img then Buffer.add_char buf '!';
@@ -1705,22 +1728,22 @@ let rec inline defs st =
if peek_after '\000' st = ']' then (
junk st;
junk st;
- reflink lab)
+ reflink label)
else
match protect (link_label false) st with
| _ ->
set_pos st off0;
junk st;
loop (Left_bracket kind :: text acc) st
- | exception Fail -> reflink lab)
+ | exception Fail -> reflink label)
| Some '(' -> (
match protect inline_link st with
| _ ->
set_pos st off0;
junk st;
loop (Left_bracket kind :: text acc) st
- | exception Fail -> reflink lab)
- | Some _ | None -> reflink lab)
+ | exception Fail -> reflink label)
+ | Some _ | None -> reflink label)
| exception Fail ->
junk st;
loop (Left_bracket kind :: text acc) st
@@ -1818,8 +1841,8 @@ let rec inline defs st =
let label = Pre.parse_emph xs in
let off1 = pos st in
match link_label false st with
- | lab -> (
- let s = normalize lab in
+ | label_text -> (
+ let s = normalize label_text in
match
List.find_opt
(fun ({ label; _ } : attributes link_def) ->
@@ -1827,7 +1850,7 @@ let rec inline defs st =
defs
with
| Some
- { label = _; destination; title; attributes = attr }
+ { destination; title; attributes = attr; _ }
->
let def = { label; destination; title } in
let r =
@@ -1923,16 +1946,24 @@ let link_reference_definition st : attributes link_def =
match next st with w when is_whitespace w -> ws st | _ -> raise Fail
in
ignore (sp3 st);
+ let is_footnote label = (String.get label 0) = '^' in
let label = link_label false st in
if next st <> ':' then raise Fail;
ws st;
let destination = link_destination st in
let attributes = inline_attribute_string st in
+ let kind = match is_footnote label with
+ | true ->
+ let label = (String.sub label 1 (String.length label - 1)) in
+ Footnote { id = Printf.sprintf "fn:%s" label; label; }
+ | false -> Reference
+ in
match protect (ws1 >>> link_title <<< sp <<< eol) st with
- | title -> { label; destination; title = Some title; attributes }
+ | title ->
+ { label; destination; title = Some title; attributes; kind }
| exception Fail ->
- (sp >>> eol) st;
- { label; destination; title = None; attributes }
+ (sp >>> eol) st;
+ { label; destination; title = None; attributes; kind; }
let link_reference_definitions st =
let rec loop acc =
diff --git a/src/sexp.ml b/src/sexp.ml
index f84a3300..778904b7 100644
--- a/src/sexp.ml
+++ b/src/sexp.ml
@@ -21,6 +21,7 @@ and inline = function
| Link (_, def) -> List [ Atom "url"; link def ]
| Html (_, s) -> List [ Atom "html"; Atom s ]
| Image _ -> Atom "img"
+ | Sup _ -> Atom "sup"
let table_header (header, alignment) =
List
@@ -60,6 +61,7 @@ let rec block = function
; List (List.map table_header headers)
; List (List.map (fun row -> List (List.map inline row)) rows)
]
+ | Footnote_list _footnotes -> List []
let create ast = List (List.map block ast)
diff --git a/src/toc.ml b/src/toc.ml
index 3aac8446..373c8a42 100644
--- a/src/toc.ml
+++ b/src/toc.ml
@@ -9,6 +9,7 @@ let rec remove_links inline =
| Image (attr, link) ->
Image (attr, { link with label = remove_links link.label })
| Hard_break _ | Soft_break _ | Html _ | Code _ | Text _ -> inline
+ | Sup (_, child) -> remove_links child
let headers =
let remove_links_f = remove_links in
@@ -26,7 +27,8 @@ let headers =
| List (_, _, _, block_lists) -> List.iter loop block_lists
| Paragraph _ | Thematic_break _ | Html_block _ | Definition_list _
| Code_block _ | Table _ ->
- ())
+ ()
+ | Footnote_list _ -> ())
blocks
in
loop doc;
diff --git a/tests/attributes.md b/tests/attributes.md
index 615a9c8d..f67331e6 100644
--- a/tests/attributes.md
+++ b/tests/attributes.md
@@ -287,3 +287,16 @@ Ref id attributes testing
````````````````````````````````
+
+Footnotes:
+
+```````````````````````````````` example
+[^footnote]
+
+[^footnote]: link
+.
+
+
+````````````````````````````````
diff --git a/tests/dune.inc b/tests/dune.inc
index 5996df97..85905d73 100644
--- a/tests/dune.inc
+++ b/tests/dune.inc
@@ -688,6 +688,7 @@
attributes-013.md attributes-013.html
attributes-014.md attributes-014.html
attributes-015.md attributes-015.html
+ attributes-016.md attributes-016.html
def_list-001.md def_list-001.html)
(action (run ./extract_tests.exe -generate-test-files %{deps})))
(rule
@@ -4847,6 +4848,13 @@
(rule
(alias attributes-015)
(action (diff attributes-015.html attributes-015.html.new)))
+(rule
+ (action
+ (with-stdout-to attributes-016.html.new
+ (run ./omd.exe %{dep:attributes-016.md}))))
+(rule
+ (alias attributes-016)
+ (action (diff attributes-016.html attributes-016.html.new)))
(rule
(action
(with-stdout-to def_list-001.html.new
@@ -5544,4 +5552,5 @@
(alias attributes-013)
(alias attributes-014)
(alias attributes-015)
+ (alias attributes-016)
(alias def_list-001)))