let of_block ?(escape_cdata=false) ?(escape_nott=false) block =
let esc s =
let strlen = String.length s in
let buf = Buffer.create strlen in
let f = function
| '&' -> Buffer.add_string buf "&"
| '<' -> Buffer.add_string buf "<"
| '>' -> Buffer.add_string buf ">"
| '"' -> Buffer.add_string buf """
| c -> Buffer.add_char buf c in
String.iter f s;
Buffer.contents buf in
let dont_esc s = s in
let print_cdata = if escape_cdata then esc else dont_esc in
let print_nott = if escape_nott then esc else dont_esc in
let parse_attr = function
| Class s -> sprintf "class=\"%s\"" (esc s)
| Id s -> sprintf "id=\"%s\"" (esc s)
| Style s -> sprintf "style=\"%s\"" (esc s)
| Language s -> sprintf "lang=\"%s\"" (esc s) in
let parse_attrs = function
| [] -> ""
| attrs ->
let buf = Buffer.create 80 in
List.iter (fun attr ->
Buffer.add_char buf ' ';
Buffer.add_string buf (parse_attr attr)) attrs;
Buffer.contents buf in
let pa = parse_attrs in
let rec parse_phrase =
let p = sprintf in
let pl = parse_line in function
| CData str -> (print_cdata str)
| Strong (a,l) -> p "<strong%s>%s</strong>" (pa a) (pl l)
| Italic (a,l) -> p "<i%s>%s</i>" (pa a) (pl l)
| Bold (a,l) -> p "<b%s>%s</b>" (pa a) (pl l)
| Emphasis (a,l) -> p "<em%s>%s</em>" (pa a) (pl l)
| Citation (a,l) -> p "<cite%s>%s</cite>" (pa a) (pl l)
| Deleted (a,l) -> p "<del%s>%s</del>" (pa a) (pl l)
| Inserted (a,l) -> p "<ins%s>%s</ins>" (pa a) (pl l)
| Superscript (a,l) -> p "<sup%s>%s</sup>" (pa a) (pl l)
| Subscript (a,l) -> p "<sub%s>%s</sub>" (pa a) (pl l)
| Span (a,l) -> p "<span%s>%s</span>" (pa a) (pl l)
| Code (a,s) -> p "<code%s>%s</code>" (pa a) (esc s)
| Notextile s -> p "%s" (print_nott s)
| Acronym (a, b) ->
p "<acronym title=\"%s\">%s</acronym>" (esc b) (print_cdata a)
| Image (a, float, src, alt) ->
(let alt = match alt with
| Some s -> let s = esc s in p "alt=\"%s\" title=\"%s\"" s s
| None -> "alt=\"\"" in
let float = match float with
| Some Float_left -> " style=\"float: left\""
| Some Float_right -> " style=\"float: right\""
| None -> "" in
p "<img %s src=\"%s\"%s%s />" alt (esc src) (pa a) float)
| Link ((attrs, l), title, url) ->
(let title = match title with
| Some s -> sprintf " title=%S" (esc s)
| None -> "" in
p "<a%s href=\"%s\"%s>%s</a>" title (esc url) (pa attrs) (pl l))
| Reference i ->
p "<sup class=\"footnote\"><a id=\"ref%d\" href=\"#fn%d\">%d</a></sup>" i i i
and parse_line line =
String.concat "" (List.map parse_phrase line) in
let parse_lines lines =
String.concat "<br />" (List.map parse_line lines) in
let to_lines print strings =
String.concat "\n" (List.map print strings) in
let parse_talign = function
| Some talign ->
(let s = match talign with
| Right -> "right"
| Left -> "left"
| Center -> "center"
| Justify -> "justify" in
sprintf " style=\"text-align:%s\"" s)
| None -> "" in
let parse_padding = function
| 0, 0 -> ""
| l, 0 ->
sprintf " style=\"padding-left:%uem\"" l
| 0, r ->
sprintf " style=\"padding-right:%uem\"" r
| l, r ->
sprintf " style=\"padding-left:%uem; padding-right:%uem\"" l r in
let parse_options (attrs, talign, padding) =
String.concat "" [parse_attrs attrs;
parse_talign talign;
parse_padding padding] in
let parse_valign = function
| Some x ->
(let s = match x with
| Top -> "top"
| Middle -> "middle"
| Bottom -> "bottom" in
sprintf " style=\"vertical-align:%s\"" s)
| None -> "" in
let parse_tableoptions (opts, valign) =
String.concat "" [parse_options opts; parse_valign valign] in
let po = parse_options in
let pt = parse_tableoptions in
let parse_cells (cells : cell list) =
String.concat "" (List.map (fun ((celltype, topts, (colspan, rowspan)), lines) ->
let tag =
match celltype with
| Data -> "td"
| Head -> "th" in
let rowspan =
match rowspan with
| Some rowspan -> sprintf " rowspan=\"%d\"" rowspan
| None -> "" in
let colspan =
match colspan with
| Some colspan -> sprintf " colspan=\"%d\"" colspan
| None -> "" in
let topts = pt topts in
let attrs = String.concat "" [topts; rowspan; colspan] in
sprintf "<%s%s>%s</%s>" tag attrs (parse_lines lines) tag) cells) in
let parse_rows (rows : Textile.row list) =
String.concat "" (List.map (fun (topts, cells) ->
sprintf "<tr%s>%s</tr>" (pt topts) (parse_cells cells)) rows) in
let parse_list f =
let rec fill_lvl filled_lvl prev acc =
function
| (lvl, line) :: t when lvl = filled_lvl ->
fill_lvl filled_lvl (parse_line line) (sprintf "%s<li>%s</li>" acc prev) t
| (lvl, line) :: t when lvl = filled_lvl + 1 ->
let first = parse_line line in
let lis, rest = fill_lvl lvl first "" t in
fill_lvl filled_lvl (prev ^ (f lis)) acc rest
| ((lvl, _) :: t) as l when lvl < filled_lvl ->
sprintf "%s<li>%s</li>" acc prev, l
| [] as l ->
sprintf "%s<li>%s</li>" acc prev, l
| (lvl, _) :: _ ->
raise (Invalid_textile (
sprintf "strange bull- or numlist: filled level is %d, but the next element has level %d"
filled_lvl lvl)) in
function
| [] -> raise (Invalid_textile "empty bull- or numlist")
| (1, line)::t ->
let first = parse_line line in
let lis, _ = fill_lvl 1 first "" t in
f lis
| _ -> raise (Invalid_textile "strange bull- or numlist") in
let pl = parse_lines in
match block with
| Header (i, (opts, lines)) ->
sprintf "<h%d%s>%s</h%d>" i (po opts) (pl lines) i
| Blockquote (opts, lines) ->
let popts = po opts in
sprintf "<blockquote%s><p%s>%s</p></blockquote>"
popts popts (pl lines)
| Footnote (i, (opts, lines)) ->
sprintf "<p id=\"fn%d\" class=\"footnote\"%s><sup>%d</sup> <a href=\"#ref%d\">↑</a> %s</p>"
i (po opts) i i (pl lines)
| Paragraph (opts, lines) ->
sprintf "<p%s>%s</p>" (po opts) (pl lines)
| Blockcode (opts, strings) ->
let popts = po opts in
sprintf "<pre%s class=\"blockcode\"><code>%s</code></pre>"
popts (to_lines esc strings)
| Pre (opts, strings) ->
sprintf "<pre%s>%s</pre>"
(po opts) (to_lines esc strings)
| Blocknott (opts, strings) ->
sprintf "<div%s>%s</div>"
(po opts) (to_lines print_nott strings)
| Numlist elements ->
parse_list (sprintf "<ol>%s</ol>") elements
| Bulllist elements ->
parse_list (sprintf "<ul>%s</ul>") elements
| Table (topts, rows) ->
sprintf "<table%s>%s</table>" (pt topts) (parse_rows rows)