Merge pull request #192 from clecat/def_list

Implementation of definition lists

src/ast.ml

@@ -62,6 +62,14 @@ module Heading = struct
     }
 end
 
+module Def_list = struct
+  type 'a elt = { term : 'a; defs : 'a list }
+  type 'a t =
+  {
+    content: 'a elt list
+  }
+end
+
 module Tag_block = struct
   type 'block t =
   {
@@ -80,6 +88,7 @@ type 'a block =
   | Code_block of Code_block.t
   | Html_block of string
   | Link_def of string Link_def.t
+  | Def_list of 'a Def_list.t
   | Tag_block of 'a block Tag_block.t
 
 module Emph = struct
@@ -160,6 +169,7 @@ let rec map f = function
   | Blockquote xs -> Blockquote (List.map (map f) xs)
   | Thematic_break -> Thematic_break
   | Heading h -> Heading {h with text = f h.text}
+  | Def_list l -> Def_list {content = List.map (fun elt -> {Def_list.term = f elt.Def_list.term; defs = List.map f elt.defs}) l.content}
   | Tag_block t -> Tag_block {t with content = List.map (map f) t.content}
   | Code_block _ | Html_block _ | Link_def _ as x -> x
 
@@ -168,7 +178,7 @@ let defs ast =
     | List l -> List.fold_left (List.fold_left loop) acc l.blocks
     | Blockquote l | Tag_block {content = l; _} -> List.fold_left loop acc l
     | Paragraph _ | Thematic_break | Heading _
-    | Code_block _ | Html_block _ -> acc
+    | Def_list _ | Code_block _ | Html_block _ -> acc
     | Link_def def -> def :: acc
   in
   List.rev (List.fold_left loop [] ast)

src/block.ml

@@ -20,6 +20,7 @@ module Pre = struct
     | Rfenced_code of int * int * Code_block.kind * (string * string) * string list * Attributes.t
     | Rindented_code of string list
     | Rhtml of Parser.html_kind * string list
+    | Rdef_list of string * string list
     | Rtag of int * int * string * t * Attributes.t
     | Rempty
 
@@ -62,6 +63,13 @@ module Pre = struct
         Code_block {kind = Some kind; label = Some label; other = Some other; code = None; attributes = a} :: blocks
     | Rfenced_code (_, _, kind, (label, other), l, a) ->
         Code_block {kind = Some kind; label = Some label; other = Some other; code = Some (concat l); attributes = a} :: blocks
+    | Rdef_list (term, defs) ->
+        let l, blocks =
+          match blocks with
+          | Def_list l :: b -> l.content, b
+          | b -> [], b
+        in
+        Def_list {content = l @ [{ Def_list.term; defs = List.rev defs}]} :: blocks
     | Rtag (_, _, tag, state, attributes) ->
         Tag_block {tag; content = close state; attributes} :: blocks
     | Rindented_code l -> (* TODO: trim from the right *)
@@ -101,8 +109,12 @@ module Pre = struct
         {blocks; next = Rindented_code [Sub.to_string s]}
     | Rempty, Llist_item (kind, indent, s) ->
         {blocks; next = Rlist (kind, Tight, false, indent, [], process empty s)}
-    | Rempty, (Lsetext_heading _ | Lparagraph | Ltag (_, _, "", _)) ->
+    | Rempty, (Lsetext_heading _ | Lparagraph | Ldef_list _ | Ltag (_, _, "", _)) ->
         {blocks; next = Rparagraph [Sub.to_string s]}
+    | Rparagraph [h], Ldef_list def ->
+        {blocks; next = Rdef_list (h, [def])}
+    | Rdef_list (term, defs), Ldef_list def ->
+        {blocks; next = Rdef_list (term, def::defs)}
     | Rempty, Ltag (ind, n, tag, attributes) ->
         {blocks; next = Rtag (ind, n, tag, empty, attributes)}
     | Rparagraph _, Llist_item ((Ordered (1, _) | Unordered _), _, s1) when not (Parser.is_empty (Parser.P.of_string (Sub.to_string s1))) ->
@@ -125,6 +137,10 @@ module Pre = struct
             s
         in
         {blocks; next = Rfenced_code (ind, num, q, info, Sub.to_string s :: lines, a)}
+    | Rdef_list (term, d::defs), Lparagraph ->
+        {blocks; next = Rdef_list (term, (d ^ "\n" ^ (Sub.to_string s))::defs)}
+    | Rdef_list _, _ ->
+        process {blocks = close {blocks; next}; next = Rempty} s
     | Rtag (_, n, _, _, _), Ltag (_, n', "", _) when n' >= n ->
         {blocks = close {blocks; next}; next = Rempty}
     | Rtag (ind, n, tag, state, attributes), _ ->

src/html.ml

@@ -12,6 +12,7 @@ type printer =
     thematic_break: printer -> Buffer.t                              -> unit;
     html_block: printer     -> Buffer.t -> string                    -> unit;
     heading: printer        -> Buffer.t -> inline Heading.t          -> unit;
+    def_list: printer       -> Buffer.t -> inline Def_list.t         -> unit;
     tag_block: printer      -> Buffer.t -> inline block Tag_block.t  -> unit;
     inline: printer         -> Buffer.t -> inline                    -> unit;
     concat: printer         -> Buffer.t -> inline list               -> unit;
@@ -266,6 +267,20 @@ let heading p b h =
   p.inline p b h.text;
   Buffer.add_string b (Printf.sprintf "</h%d>" h.level)
 
+let def_list p b l =
+  Buffer.add_string b (Printf.sprintf "<dl>\n");
+  List.iter (fun {Def_list.term; defs} ->
+    Buffer.add_string b (Printf.sprintf "<dt>");
+    p.inline p b term;
+    Buffer.add_string b (Printf.sprintf "</dt>\n");
+    List.iter (fun s ->
+      Buffer.add_string b (Printf.sprintf "<dd>");
+      p.inline p b s;
+      Buffer.add_string b (Printf.sprintf "</dd>\n")
+    ) defs;
+  ) l.Def_list.content;
+  Buffer.add_string b (Printf.sprintf "</dl>")
+
 let tag_block p b t =
   let f i block =
     p.block p b block;
@@ -289,6 +304,8 @@ let block p b = function
       p.html_block p b body
   | Heading h ->
       p.heading p b h
+  | Def_list l ->
+      p.def_list p b l
   | Tag_block t ->
       p.tag_block p b t
   | Link_def _ ->
@@ -306,6 +323,7 @@ let default_printer =
     thematic_break;
     html_block;
     heading;
+    def_list;
     tag_block;
     inline;
     concat;

src/omd.ml

@@ -12,6 +12,7 @@ type printer = Html.printer =
     thematic_break: printer -> Buffer.t                              -> unit;
     html_block: printer     -> Buffer.t -> string                    -> unit;
     heading: printer        -> Buffer.t -> inline Heading.t          -> unit;
+    def_list: printer       -> Buffer.t -> inline Def_list.t         -> unit;
     tag_block: printer      -> Buffer.t -> inline block Tag_block.t  -> unit;
     inline: printer         -> Buffer.t -> inline                    -> unit;
     concat: printer         -> Buffer.t -> inline list               -> unit;

src/omd.mli

@@ -6,6 +6,7 @@ module Link_def = Ast.Link_def
 module Block_list = Ast.Block_list
 module Code_block = Ast.Code_block
 module Heading = Ast.Heading
+module Def_list = Ast.Def_list
 module Tag_block = Ast.Tag_block
 
 type 'a block = 'a Ast.block =
@@ -17,6 +18,7 @@ type 'a block = 'a Ast.block =
   | Code_block of Code_block.t
   | Html_block of string
   | Link_def of string Link_def.t
+  | Def_list of 'a Def_list.t
   | Tag_block of 'a block Tag_block.t
 
 module Emph = Ast.Emph
@@ -52,6 +54,7 @@ type printer = Html.printer =
     thematic_break: printer -> Buffer.t                              -> unit;
     html_block: printer     -> Buffer.t -> string                    -> unit;
     heading: printer        -> Buffer.t -> inline Heading.t          -> unit;
+    def_list: printer       -> Buffer.t -> inline Def_list.t         -> unit;
     tag_block: printer      -> Buffer.t -> inline block Tag_block.t  -> unit;
     inline: printer         -> Buffer.t -> inline                    -> unit;
     concat: printer         -> Buffer.t -> inline list               -> unit;

src/parser.ml

@@ -270,6 +270,7 @@ type t =
   | Lhtml of bool * html_kind
   | Llist_item of Block_list.kind * int * Sub.t
   | Lparagraph
+  | Ldef_list of string
   | Ltag of int * int * string * Attributes.t
 
 let sp3 s =
@@ -788,6 +789,12 @@ let tag_string s =
   in
   loop (ws s)
 
+let def_list s =
+  let s = Sub.tail s in
+  match Sub.head (s) with
+  | Some (' ' | '\t' | '\010'..'\013') -> Ldef_list (String.trim (Sub.to_string s))
+  | _ -> raise Fail
+
 let tag ind s =
   match Sub.head s with
   | Some '+' ->
@@ -833,6 +840,8 @@ let parse s0 =
       (tag ind ||| unordered_list_item ind) s
   | Some ('0'..'9') ->
       ordered_list_item ind s
+  | Some ':' ->
+      def_list s
   | Some _ ->
       (blank ||| indented_code ind) s
   | None ->

src/sexp.ml

@@ -60,6 +60,8 @@ let rec block = function
       List [Atom "html"; Atom s]
   | Link_def {label; destination; _} ->
       List [Atom "link-def"; Atom label; Atom destination]
+  | Def_list {content} ->
+      List [Atom "def-list"; List (List.map (fun elt -> List [inline elt.Def_list.term; List (List.map inline elt.defs)]) content)]
   | Tag_block {tag; content; _} ->
       List [Atom "tag"; Atom tag; List (List.map block content)]
 

tests/def_list/def_list.html

@@ -0,0 +1,9 @@
+<dl>
+<dt>First Term</dt>
+<dd>This is the definition of the first term.</dd>
+<dt>Second Term</dt>
+<dd>This is one definition of the second term.</dd>
+<dd>This is another definition of the second term.
+which is multiline</dd>
+</dl>
+<p>: This is not a correct definition list</p>

tests/def_list/def_list.md

@@ -0,0 +1,9 @@
+First Term
+: This is the definition of the first term.
+
+Second Term
+: This is one definition of the second term.
+: This is another definition of the second term.
+which is multiline
+
+: This is not a correct definition list

tests/def_list/dune

@@ -0,0 +1,12 @@
+(rule
+ (targets def_list.html.out)
+ (deps def_list.md)
+ (action (with-stdout-to %{targets} (run omd %{deps}))))
+
+(alias
+ (name def_list)
+ (action (diff def_list.html def_list.html.out)))
+
+(alias
+ (name runtest)
+ (deps (alias def_list)))