Add Footnote Support

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)

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

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

src/omd.ml

@@ -15,14 +15,26 @@ 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) =
       { def with label = Parser.normalize def.label }
     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)

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,22 +1681,40 @@ 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
             List.find_opt
               (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
                 match kind with
                 | 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,16 +1841,16 @@ 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) ->
                             label = s)
                           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 =

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)
 

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;

tests/attributes.md

@@ -287,3 +287,16 @@ Ref id attributes testing
 <p><img src="ref_3" alt="Ref 3" id="id1" /></p>
 <p><img src="ref_4" alt="Ref 4" id="id2b" /></p>
 ````````````````````````````````
+
+Footnotes:
+
+```````````````````````````````` example
+[^footnote]
+
+[^footnote]: link
+.
+<p><sup><a href="#fn:footnote" id="fnref:footnote">footnote</a></sup></p>
+<div class="footnotes"><hr /><ol><li id="fn:footnote"><p>link<a href="#fnref:footnote">↩</a></p></li>
+</ol>
+</div>
+````````````````````````````````