mirror of
https://github.com/KevinMidboe/linguist.git
synced 2025-10-29 17:50:22 +00:00
631 lines
19 KiB
Raku
Executable File
631 lines
19 KiB
Raku
Executable File
#!/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);
|
|
}
|
|
elsif $c ~~ Str {
|
|
@chunks.push: $c.indent($level + 2), "\n";
|
|
} elsif $c ~~ Positional {
|
|
@chunks.push: $c.map: {
|
|
if $_ ~~ Pod::Block {
|
|
*.&pod-gist
|
|
} elsif $_ ~~ Str {
|
|
$_
|
|
}
|
|
}
|
|
}
|
|
}
|
|
@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 (0..* Z @source) -> $num, $_ {
|
|
my $podname = .key;
|
|
my $file = .value;
|
|
my $what = $podname ~~ /^<[A..Z]> | '::'/ ?? 'type' !! 'language';
|
|
printf "% 4d/%d: % -40s => %s\n", $num, +@source, $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>
|
|
];
|
|
}
|