Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

executable file 623 lines (567 sloc) 18.962 kb
#!/usr/bin/env perl6
use v6;
# This script isn't in bin/ because it's not meant to be installed.
BEGIN say 'Initializing ...';
use Pod::To::HTML;
use URI::Escape;
use lib 'lib';
use Perl6::TypeGraph;
use Perl6::TypeGraph::Viz;
use Perl6::Documentable::Registry;
my $*DEBUG = False;
my $tg;
my %methods-by-type;
my $footer = footer-html;
my $head = q[
<link rel="icon" href="/favicon.ico" type="favicon.ico" />
<link rel="stylesheet" type="text/css" href="/style.css" media="screen" title="default" />
];
sub url-munge($_) {
return $_ if m{^ <[a..z]>+ '://'};
return "/type/$_" if m/^<[A..Z]>/;
return "/routine/$_" if m/^<[a..z]>/;
# poor man's <identifier>
if m/ ^ '&'( \w <[[\w'-]>* ) $/ {
return "/routine/$0";
}
return $_;
}
sub p2h($pod) {
pod2html($pod, :url(&url-munge), :$footer, :$head);
}
sub pod-gist(Pod::Block $pod, $level = 0) {
my $leading = ' ' x $level;
my %confs;
my @chunks;
for <config name level caption type> {
my $thing = $pod.?"$_"();
if $thing {
%confs{$_} = $thing ~~ Iterable ?? $thing.perl !! $thing.Str;
}
}
@chunks = $leading, $pod.^name, (%confs.perl if %confs), "\n";
for $pod.content.list -> $c {
if $c ~~ Pod::Block {
@chunks.push: pod-gist($c, $level + 2);
}
else {
@chunks.push: $c.indent($level + 2), "\n";
}
}
@chunks.join;
}
sub recursive-dir($dir) {
my @todo = $dir;
gather while @todo {
my $d = @todo.shift;
for dir($d) -> $f {
if $f.f {
take $f;
}
else {
@todo.push($f.path);
}
}
}
}
sub first-code-block(@pod) {
if @pod[1] ~~ Pod::Block::Code {
return @pod[1].content.grep(Str).join;
}
'';
}
sub MAIN(Bool :$debug, Bool :$typegraph = False) {
$*DEBUG = $debug;
say 'Creating html/ subdirectories ...';
for '', <type language routine images op op/prefix op/postfix op/infix
op/circumfix op/postcircumfix op/listop> {
mkdir "html/$_" unless "html/$_".IO ~~ :e;
}
say 'Reading lib/ ...';
my @source = recursive-dir('lib').grep(*.f).grep(rx{\.pod$});
@source .= map: {; .path.subst('lib/', '').subst(rx{\.pod$}, '').subst(:g, '/', '::') => $_ };
say 'Reading type graph ...';
$tg = Perl6::TypeGraph.new-from-file('type-graph.txt');
{
my %h = $tg.sorted.kv.flat.reverse;
@source .= sort: { %h{.key} // -1 };
}
my $dr = Perl6::Documentable::Registry.new;
say 'Processing Pod files ...';
for (@source) {
my $podname = .key;
my $file = .value;
my $what = $podname ~~ /^<[A..Z]> | '::'/ ?? 'type' !! 'language';
say "$file.path() => $what/$podname";
my $pod = eval slurp($file.path) ~ "\n\$=pod";
$pod .= [0];
if $what eq 'language' {
write-language-file(:$dr, :$what, :$pod, :$podname);
}
else {
say pod-gist($pod[0]) if $*DEBUG;
write-type-file(:$dr, :$what, :pod($pod[0]), :$podname);
}
}
say 'Composing doc registry ...';
$dr.compose;
write-disambiguation-files($dr);
write-op-disambiguation-files($dr);
write-operator-files($dr);
write-type-graph-images(:force($typegraph));
write-search-file($dr);
write-index-file($dr);
say 'Writing per-routine files ...';
my %routine-seen;
for $dr.lookup('routine', :by<kind>).list -> $d {
next if %routine-seen{$d.name}++;
write-routine-file($dr, $d.name);
print '.'
}
say '';
say 'Processing complete.';
}
sub write-language-file(:$dr, :$what, :$pod, :$podname) {
spurt "html/$what/$podname.html", p2h($pod);
if $podname eq 'operators' {
my @chunks = chunks-grep($pod.content,
:from({ $_ ~~ Pod::Heading and .level == 2}),
:to({ $^b ~~ Pod::Heading and $^b.level <= $^a.level}),
);
for @chunks -> $chunk {
my $heading = $chunk[0].content[0].content[0];
next unless $heading ~~ / ^ [in | pre | post | circum | postcircum ] fix | listop /;
my $what = ~$/;
my $operator = $heading.split(' ', 2)[1];
$dr.add-new(
:kind<operator>,
:subkind($what),
:name($operator),
:pod($chunk),
:!pod-is-complete,
);
}
}
$dr.add-new(
:kind<language>,
:name($podname),
:$pod,
:pod-is-complete,
);
}
sub write-type-file(:$dr, :$what, :$pod, :$podname) {
my @chunks = chunks-grep($pod.content,
:from({ $_ ~~ Pod::Heading and .level == 2}),
:to({ $^b ~~ Pod::Heading and $^b.level <= $^a.level}),
);
if $tg.types{$podname} -> $t {
$pod.content.push: Pod::Block::Named.new(
name => 'Image',
content => [ "/images/type-graph-$podname.png"],
);
$pod.content.push: pod-link(
'Full-size type graph image as SVG',
"/images/type-graph-$podname.svg",
);
my @mro = $t.mro;
@mro.shift; # current type is already taken care of
for $t.roles -> $r {
next unless %methods-by-type{$r};
$pod.content.push:
pod-heading("Methods supplied by role $r"),
pod-block(
"$podname does role ",
pod-link($r.name, "/type/$r"),
", which provides the following methods:",
),
%methods-by-type{$r}.list,
;
}
for @mro -> $c {
next unless %methods-by-type{$c};
$pod.content.push:
pod-heading("Methods supplied by class $c"),
pod-block(
"$podname inherits from class ",
pod-link($c.name, "/type/$c"),
", which provides the following methods:",
),
%methods-by-type{$c}.list,
;
for $c.roles -> $r {
next unless %methods-by-type{$r};
$pod.content.push:
pod-heading("Methods supplied by role $r"),
pod-block(
"$podname inherits from class ",
pod-link($c.name, "/type/$c"),
", which does role ",
pod-link($r.name, "/type/$r"),
", which provides the following methods:",
),
%methods-by-type{$r}.list,
;
}
}
}
my $d = $dr.add-new(
:kind<type>,
# TODO: subkind
:$pod,
:pod-is-complete,
:name($podname),
);
for @chunks -> $chunk {
my $name = $chunk[0].content[0].content[0];
say "$podname.$name" if $*DEBUG;
next if $name ~~ /\s/;
%methods-by-type{$podname}.push: $chunk;
# determine whether it's a sub or method
my Str $subkind;
{
my %counter;
for first-code-block($chunk).lines {
if ms/^ 'multi'? (sub|method)»/ {
%counter{$0}++;
}
}
if %counter == 1 {
($subkind,) = %counter.keys;
}
if %counter<method> {
write-qualified-method-call(
:$name,
:pod($chunk),
:type($podname),
);
}
}
$dr.add-new(
:kind<routine>,
:$subkind,
:$name,
:pod($chunk),
:!pod-is-complete,
:origin($d),
);
}
spurt "html/$what/$podname.html", p2h($pod);
}
sub chunks-grep(:$from!, :&to!, *@elems) {
my @current;
gather {
for @elems -> $c {
if @current && ($c ~~ $from || to(@current[0], $c)) {
take [@current];
@current = ();
@current.push: $c if $c ~~ $from;
}
elsif @current or $c ~~ $from {
@current.push: $c;
}
}
take [@current] if @current;
}
}
sub pod-with-title($title, *@blocks) {
Pod::Block::Named.new(
name => "pod",
content => [
Pod::Block::Named.new(
name => "TITLE",
content => Array.new(
Pod::Block::Para.new(
content => [$title],
)
)
),
@blocks.flat,
]
);
}
sub pod-block(*@content) {
Pod::Block::Para.new(:@content);
}
sub pod-link($text, $url) {
Pod::FormattingCode.new(
type => 'L',
content => [
join('|', $text, $url),
],
);
}
sub pod-item(*@content, :$level = 1) {
Pod::Item.new(
:$level,
:@content,
);
}
sub pod-heading($name, :$level = 1) {
Pod::Heading.new(
:$level,
:content[pod-block($name)],
);
}
sub write-type-graph-images(:$force) {
unless $force {
my $dest = 'html/images/type-graph-Any.svg'.path;
if $dest.e && $dest.modified >= 'type-graph.txt'.path.modified {
say "Not writing type graph images, it seems to be up-to-date";
say "To force writing of type graph images, supply the --typegraph";
say "option at the command line, or delete";
say "file 'html/images/type-graph-Any.svg'";
return;
}
}
say 'Writing type graph images to html/images/ ...';
for $tg.sorted -> $type {
my $viz = Perl6::TypeGraph::Viz.new-for-type($type);
$viz.to-file("html/images/type-graph-{$type}.svg", format => 'svg');
$viz.to-file("html/images/type-graph-{$type}.png", format => 'png', size => '8,3');
print '.'
}
say '';
say 'Writing specialized visualizations to html/images/ ...';
my %by-group = $tg.sorted.classify(&viz-group);
%by-group<Exception>.push: $tg.types< Exception Any Mu >;
%by-group<Metamodel>.push: $tg.types< Any Mu >;
for %by-group.kv -> $group, @types {
my $viz = Perl6::TypeGraph::Viz.new(:types(@types),
:dot-hints(viz-hints($group)),
:rank-dir('LR'));
$viz.to-file("html/images/type-graph-{$group}.svg", format => 'svg');
$viz.to-file("html/images/type-graph-{$group}.png", format => 'png', size => '8,3');
}
}
sub viz-group ($type) {
return 'Metamodel' if $type.name ~~ /^ 'Perl6::Metamodel' /;
return 'Exception' if $type.name ~~ /^ 'X::' /;
return 'Any';
}
sub viz-hints ($group) {
return '' unless $group eq 'Any';
return '
subgraph "cluster: Mu children" {
rank=same;
style=invis;
"Any";
"Junction";
}
subgraph "cluster: Pod:: top level" {
rank=same;
style=invis;
"Pod::Config";
"Pod::Block";
}
subgraph "cluster: Date/time handling" {
rank=same;
style=invis;
"Date";
"DateTime";
"DateTime-local-timezone";
}
subgraph "cluster: Collection roles" {
rank=same;
style=invis;
"Positional";
"Associative";
"Baggy";
}
';
}
sub write-search-file($dr) {
say 'Writing html/search.html ...';
my $template = slurp("search_template.html");
my @items;
my sub fix-url ($raw) { $raw.substr(1) ~ '.html' };
@items.push: $dr.lookup('language', :by<kind>).sort(*.name).map({
"\{ label: \"Language: {.name}\", value: \"{.name}\", url: \"{ fix-url(.url) }\" \}"
});
@items.push: $dr.lookup('type', :by<kind>).sort(*.name).map({
"\{ label: \"Type: {.name}\", value: \"{.name}\", url: \"{ fix-url(.url) }\" \}"
});
my %seen;
@items.push: $dr.lookup('routine', :by<kind>).grep({!%seen{.name}++}).sort(*.name).map({
"\{ label: \"{ (.subkind // 'Routine').tclc }: {.name}\", value: \"{.name}\", url: \"{ fix-url(.url) }\" \}"
});
sub escape(Str $s) {
$s.trans([</ \\ ">] => [<\\/ \\\\ \\">]);
}
@items.push: $dr.lookup('operator', :by<kind>).map({
qq[\{ label: "$_.human-kind() {escape .name}", value: "{escape .name}", url: "{ fix-url .url }"\}]
});
my $items = @items.join(",\n");
spurt("html/search.html", $template.subst("ITEMS", $items));
}
my %operator_disambiguation_file_written;
sub write-disambiguation-files($dr) {
say 'Writing disambiguation files ...';
for $dr.grouped-by('name').kv -> $name, $p is copy {
print '.';
my $pod = pod-with-title("Disambiguation for '$name'");
if $p.elems == 1 {
$p.=[0] if $p ~~ Array;
if $p.origin -> $o {
$pod.content.push:
pod-block(
pod-link("'$name' is a $p.human-kind()", $p.url),
' from ',
pod-link($o.human-kind() ~ ' ' ~ $o.name, $o.url),
);
}
else {
$pod.content.push:
pod-block(
pod-link("'$name' is a $p.human-kind()", $p.url)
);
}
}
else {
$pod.content.push:
pod-block("'$name' can be anything of the following"),
$p.map({
if .origin -> $o {
pod-item(
pod-link(.human-kind, .url),
' from ',
pod-link($o.human-kind() ~ ' ' ~ $o.name, $o.url),
)
}
else {
pod-item( pod-link(.human-kind, .url) )
}
});
}
my $html = p2h($pod);
spurt "html/$name.html", $html;
if all($p>>.kind) eq 'operator' {
spurt "html/op/$name.html", $html;
%operator_disambiguation_file_written{$p[0].name} = 1;
}
}
say '';
}
sub write-op-disambiguation-files($dr) {
say 'Writing operator disambiguation files ...';
for $dr.lookup('operator', :by<kind>).classify(*.name).kv -> $name, @ops {
next unless %operator_disambiguation_file_written{$name};
my $pod = pod-with-title("Disambiguation for '$name'");
if @ops == 1 {
my $p = @ops[0];
if $p.origin -> $o {
$pod.content.push:
pod-block(
pod-link("'$name' is a $p.human-kind()", $p.url),
' from ',
pod-link($o.human-kind() ~ ' ' ~ $o.name, $o.url),
);
}
else {
$pod.content.push:
pod-block(
pod-link("'$name' is a $p.human-kind()", $p.url)
);
}
}
else {
$pod.content.push:
pod-block("'$name' can be anything of the following"),
@ops.map({
if .origin -> $o {
pod-item(
pod-link(.human-kind, .url),
' from ',
pod-link($o.human-kind() ~ ' ' ~ $o.name, $o.url),
)
}
else {
pod-item( pod-link(.human-kind, .url) )
}
});
}
my $html = p2h($pod);
spurt "html/$name.html", $html;
}
}
sub write-operator-files($dr) {
say 'Writing operator files ...';
for $dr.lookup('operator', :by<kind>).list -> $doc {
my $what = $doc.subkind;
my $op = $doc.name;
my $pod = pod-with-title(
"$what.tclc() $op operator",
pod-block(
"Documentation for $what $op, extracted from ",
pod-link("the operators language documentation", "/language/operators")
),
@($doc.pod),
);
spurt "html/op/$what/$op.html", p2h($pod);
}
}
sub write-index-file($dr) {
say 'Writing html/index.html ...';
my %routine-seen;
my $pod = pod-with-title('Perl 6 Documentation',
Pod::Block::Para.new(
content => ['Official Perl 6 documentation'],
),
# TODO: add more
pod-heading("Language Documentation"),
$dr.lookup('language', :by<kind>).sort(*.name).map({
pod-item( pod-link(.name, .url) )
}),
pod-heading('Types'),
$dr.lookup('type', :by<kind>).sort(*.name).map({
pod-item(pod-link(.name, .url))
}),
pod-heading('Routines'),
$dr.lookup('routine', :by<kind>).sort(*.name).map({
next if %routine-seen{.name}++;
pod-item(pod-link(.name, .url))
}),
);
spurt 'html/index.html', p2h($pod);
}
sub write-routine-file($dr, $name) {
say 'Writing html/routine/$name.html ...' if $*DEBUG;
my @docs = $dr.lookup($name, :by<name>).grep(*.kind eq 'routine');
my $subkind = 'routine';
{
my @subkinds = @docs>>.subkind;
$subkind = @subkinds[0] if all(@subkinds>>.defined) && [eq] @subkinds;
}
my $pod = pod-with-title("Documentation for $subkind $name",
pod-block("Documentation for $subkind $name, assembled from the
following types:"),
@docs.map({
pod-heading(.origin.name ~ '.' ~ .name),
pod-block("From ", pod-link(.origin.name, .origin.url ~ '#' ~ .name)),
.pod.list,
})
);
spurt "html/routine/$name.html", p2h($pod);
}
sub write-qualified-method-call(:$name!, :$pod!, :$type!) {
my $p = pod-with-title(
"Documentation for method $type.$name",
pod-block('From ', pod-link($type, "/type/{$type}#$name")),
@$pod,
);
spurt "html/{$type}.{$name}.html", p2h($p);
}
sub footer-html() {
state $dt = ~DateTime.now;
qq[
<div id="footer">
<p>
Generated on $dt from the sources at
<a href="https://github.com/perl6/doc">perl6/doc on github</a>.
</p>
<p>
This is a work in progress to document Perl 6, and known to be
incomplete. Your contribution is appreciated.
</p>
</div>
];
}
Jump to Line
Something went wrong with that request. Please try again.