Skip to content
Fetching contributors…
Cannot retrieve contributors at this time
412 lines (350 sloc) 12 KB
class Pod::To::HTML;
use URI::Escape;
method render($pod) {
pod2html($pod)
}
# FIXME: this code's a horrible mess. It'd be really helpful to have a module providing a generic
# way to walk a Pod tree and invoke callbacks on each node, that would reduce the multispaghetti at
# the bottom to something much more readable.
my $title;
my @meta;
my @indexes;
my @body;
my @footnotes;
sub Debug(Callable $) { } # Disable debug code
#sub Debug(Callable $c) { $c() } # Enable debug code
sub escape_html(Str $str) returns Str {
return $str unless $str ~~ /<[&<>"']>/;
$str.trans( [ q{&}, q{<}, q{>}, q{"}, q{'} ] =>
[ q{&amp;}, q{&lt;}, q{&gt;}, q{&quot;}, q{&#39;} ] );
}
#= Converts a Pod tree to a HTML document.
sub pod2html($pod) is export returns Str {
@body.push: node2html($pod);
my $title_html = $title // 'Pod document';
# TODO: make this look nice again when q:to"" gets implemented
my @prelude = (
'<!doctype html>',
'<html>',
'<head>',
' <title>' ~ $title_html ~ '</title>',
' <meta charset="UTF-8" />',
' <style>',
# code gets the browser-default font
# kbd gets a slightly less common monospace font
# samp gets the hard pixelly fonts
' kbd { font-family: "Droid Sans Mono", "Luxi Mono", "Inconsolata", monospace }',
' samp { font-family: "Terminus", "Courier", "Lucida Console", monospace }',
# WHATWG HTML frowns on the use of <u> because it looks like a link,
# so we make it not look like one.
' u { text-decoration: none }',
# footnote things:
' aside, u { opacity: 0.7 }',
' a[id^="fn-"]:target { background: #ff0 }',
' </style>',
' <link rel="stylesheet" href="http://perlcabal.org/syn/perl.css">',
( do-metadata() // () ),
'</head>',
'<body class="pod" id="___top">',
);
return join(qq{\n},
@prelude,
( $title.defined ?? "<h1>{$title_html}</h1>"
!! () ),
( do-toc() // () ),
@body,
do-footnotes(),
'</body>',
"</html>\n"
);
}
#= Returns accumulated metadata as a string of C«<meta>» tags
sub do-metadata returns Str {
return @meta.map(-> $p {
qq[<meta name="{escape_html($p.key)}" value="{node2text($p.value)}" />]
}).join("\n");
}
#= Turns accumulated headings into a nested-C«<ol>» table of contents
sub do-toc returns Str {
my $r = qq[<nav class="indexgroup">\n];
my $indent = q{ } x 2;
my @opened;
for @indexes -> $p {
my $lvl = $p.key;
my %head = $p.value;
if +@opened {
while @opened[*-1] > $lvl {
$r ~= $indent x @opened - 1
~ "</ol>\n";
@opened.pop;
}
}
my $last = @opened[*-1] // 0;
if $last < $lvl {
$r ~= $indent x $last
~ qq[<ol class="indexList indexList{$lvl}">\n];
@opened.push($lvl);
}
$r ~= $indent x $lvl
~ qq[<li class="indexItem indexItem{$lvl}">]
~ qq[<a href="#{%head<uri>}">{%head<html>}</a>\n];
}
for ^@opened {
$r ~= $indent x @opened - 1 - $^left
~ "</ol>\n";
}
return $r ~ '</nav>';
}
#= Keep count of how many footnotes we've output.
my Int $done-notes = 0;
#= Flushes accumulated footnotes since last call. The idea here is that we can stick calls to this
# before each C«</section>» tag (once we have those per-header) and have notes that are visually
# and semantically attached to the section.
sub do-footnotes returns Str {
#state $done-notes = 0; # TODO 2011-09-07 Rakudo-nom bug
return '' unless @footnotes;
my Int $current-note = $done-notes + 1;
my $notes = @footnotes.kv.map(-> $k, $v {
my $num = $k + $current-note;
qq{<li><a href="#fn-ref-$num" id="fn-$num">[↑]</a> $v </li>\n}
}).join;
$done-notes += @footnotes;
@footnotes = ();
return qq[<aside><ol start="$current-note">\n]
~ $notes
~ qq[</ol></aside>\n];
}
sub twine2text($twine) returns Str {
Debug { say "twine2text called for {$twine.perl}" };
return '' unless $twine.elems;
my $r = $twine[0];
for $twine[1..*] -> $f, $s {
$r ~= twine2text($f.content);
$r ~= $s;
}
return $r;
}
#= block level or below
multi sub node2html($node) returns Str {
Debug { say "Generic node2html called for {$node.perl}" };
return node2inline($node);
}
multi sub node2html(Pod::Block::Declarator $node) returns Str {
given $node.WHEREFORE {
when Sub {
"<article>\n"
~ '<code>'
~ node2text($node.WHEREFORE.name ~ $node.WHEREFORE.signature.perl)
~ "</code>:\n"
~ node2html($node.content)
~ "\n</article>\n";
}
default {
Debug { say "I don't know what {$node.WHEREFORE.perl} is" };
node2html([$node.WHEREFORE.perl, q{: }, $node.content]);
}
}
}
multi sub node2html(Pod::Block::Code $node) returns Str {
Debug { say "Code node2html called for {$node.perl}" };
return '<pre>' ~ node2inline($node.content) ~ "</pre>\n"
}
multi sub node2html(Pod::Block::Comment $node) returns Str {
Debug { say "Comment node2html called for {$node.perl}" };
return '';
}
multi sub node2html(Pod::Block::Named $node) returns Str {
Debug { say "Named Block node2html called for {$node.perl}" };
given $node.name {
when 'config' { return '' }
when 'nested' { return '' }
when 'pod' { return node2html($node.content); }
when 'para' { return node2html($node.content[0]); }
when 'defn' {
return node2html($node.content[0]) ~ "\n"
~ node2html($node.content[1..*-1]);
}
default {
if $node.name eq 'TITLE' {
$title = node2text($node.content);
return '';
}
elsif $node.name ~~ any(<VERSION DESCRIPTION AUTHOR COPYRIGHT SUMMARY>)
and $node.content[0] ~~ Pod::Block::Para {
@meta.push: Pair.new(
key => $node.name.lc,
value => $node.content
);
}
return '<section>'
~ "<h1>{$node.name}</h1>\n"
~ node2html($node.content)
~ "</section>\n";
}
}
}
multi sub node2html(Pod::Block::Para $node) returns Str {
Debug { say "Para node2html called for {$node.perl}" };
return '<p>' ~ node2inline($node.content) ~ "</p>\n";
}
multi sub node2html(Pod::Block::Table $node) returns Str {
Debug { say "Table node2html called for {$node.perl}" };
my @r = '<table>';
if $node.caption {
@r.push("<caption>{node2inline($node.caption)}</caption>");
}
if $node.headers {
@r.push(
'<thead><tr>',
$node.headers.map(-> $cell {
"<th>{node2html($cell)}</th>"
}),
'</tr></thead>'
);
}
@r.push(
'<tbody>',
$node.content.map(-> $line {
'<tr>',
$line.list.map(-> $cell {
"<td>{node2html($cell)}</td>"
}),
'</tr>'
}),
'</tbody>',
'</table>'
);
return @r.join("\n");
}
multi sub node2html(Pod::Config $node) returns Str {
Debug { say "Config node2html called for {$node.perl}" };
return '';
}
# TODO: would like some way to wrap these and the following content in a <section>; this might be
# the same way we get lists working...
multi sub node2html(Pod::Heading $node) returns Str {
Debug { say "Heading node2html called for {$node.perl}" };
my $lvl = min($node.level, 6); #= HTML only has 6 levels of numbered headings
my %escaped = (
uri => uri_escape(node2rawtext($node.content)),
html => node2inline($node.content),
);
@indexes.push: Pair.new(key => $lvl, value => %escaped);
return sprintf('<h%d id="%s">', $lvl, %escaped<uri>)
~ qq[<a class="u" href="#___top" title="go to top of document">]
~ %escaped<html>
~ qq[</a>]
~ qq[</h{$lvl}>\n];
}
# FIXME
multi sub node2html(Pod::Item $node) returns Str {
Debug { say "List Item node2html called for {$node.perl}" };
return '<ul><li>' ~ node2html($node.content) ~ "</li></ul>";
}
multi sub node2html(Positional $node) returns Str {
return $node.map({ node2html($_) }).join
}
multi sub node2html(Str $node) returns Str {
return escape_html($node);
}
#= inline level or below
multi sub node2inline($node) returns Str {
Debug { say "missing a node2inline multi for {$node.perl}" };
return node2text($node);
}
multi sub node2inline(Pod::Block::Para $node) returns Str {
return node2inline($node.content);
}
multi sub node2inline(Pod::FormattingCode $node) returns Str {
my %basic-html = (
B => 'strong', #= Basis
C => 'code', #= Code
I => 'em', #= Important
K => 'kbd', #= Keyboard
R => 'var', #= Replaceable
T => 'samp', #= Terminal
U => 'u', #= Unusual
);
given $node.type {
when any(%basic-html.keys) {
return q{<} ~ %basic-html{$_} ~ q{>}
~ node2inline($node.content)
~ q{</} ~ %basic-html{$_} ~ q{>};
}
#= Escape
when 'E' {
return $node.content.split(q{;}).map({
# Perl 6 numbers = Unicode codepoint numbers
when /^ \d+ $/
{ q{&#} ~ $_ ~ q{;} }
# Lowercase = HTML5 entity reference
when /^ <[a..z]>+ $/
{ q{&} ~ $_ ~ q{;} }
# Uppercase = Unicode codepoint names
default
{ q{<kbd class="pod2html-todo">E&lt;} ~ node2text($_) ~ q{&gt;</kbd>} }
}).join;
}
#= Note
when 'N' {
@footnotes.push(node2inline($node.content));
my $id = +@footnotes;
return qq{<a href="#fn-$id" id="fn-ref-$id">[$id]</a>};
}
#= Links
when 'L' {
my $url = $node.content.join;
my $text = $url;
if $url ~~ /'|'/ {
$text = $/.prematch;
$url = $/.postmatch;
}
# TODO: URI-escape $url
$text = escape_html $text;
return qq{<a href="$url">$text</a>}
}
# Stuff I haven't figured out yet
default {
return qq{<kbd class="pod2html-todo">{$node.type}&lt;}
~ node2inline($node.content)
~ q{&gt;</kbd>};
}
}
}
multi sub node2inline(Positional $node) returns Str {
return $node.map({ node2inline($_) }).join;
}
multi sub node2inline(Str $node) returns Str {
return escape_html($node);
}
#= HTML-escaped text
multi sub node2text($node) returns Str {
Debug { say "missing a node2text multi for {$node.perl}" };
return escape_html(node2rawtext($node));
}
multi sub node2text(Pod::Block::Para $node) returns Str {
return node2text($node.content);
}
# FIXME: a lot of these multis are identical except the function name used...
# there has to be a better way to write this?
multi sub node2text(Positional $node) returns Str {
return $node.map({ node2text($_) }).join;
}
multi sub node2text(Str $node) returns Str {
return escape_html($node);
}
#= plain, unescaped text
multi sub node2rawtext($node) returns Str {
Debug { say "Generic node2rawtext called with {$node.perl}" };
return $node.Str;
}
multi sub node2rawtext(Pod::Block $node) returns Str {
Debug { say "node2rawtext called for {$node.perl}" };
return twine2text($node.content);
}
multi sub node2rawtext(Positional $node) returns Str {
return $node.map({ node2rawtext($_) }).join;
}
multi sub node2rawtext(Str $node) returns Str {
return $node;
}
Jump to Line
Something went wrong with that request. Please try again.