bin/feature-check.pl



#!/usr/bin/perl

use v5.14;
use utf8;
use warnings;
use open qw( :std :encoding(UTF-8) );

use Getopt::Long 2.24 qw(:config gnu_getopt);
use IO::Interactive qw(is_interactive);

my $USE_COLOR;
BEGIN {
    $USE_COLOR = !(
           exists $ENV{NO_COLOR}
        or ( $ENV{COLOR} and !$ENV{COLOR} )
        or !is_interactive
    );
    $Pod::Usage::Formatter = 'Pod::Text::Color' if $USE_COLOR;
}
use Pod::Usage;

my $COPYRIGHT;
use Pod::Constants
    -trim => 1,
    'COPYRIGHT AND LICENSE' =>
    sub { ($COPYRIGHT) = s/C<< (.*) >>/$1/gr; $COPYRIGHT =~ s/Â©/©/g };

use List::Util qw(max);
use Readonly::Tiny;
use Path::Tiny;
use Log::Any qw($log);
use Log::Any::Adapter;
use Term::Table;
use Graph::Easy;
use Graph::Easy::Parser;

# TODO: handle options --quiet/--verbose/--debug
# TODO: handle output scope, with options --threshold/--all
# TODO: handle custom basepath (with builtin as default), taken as argument
# TODO: handle multiple basepaths
# TODO: check scripts (not only documentation)

Log::Any::Adapter->set( 'Screen', use_color => $USE_COLOR );

=head1 NAME

feature-check - examine maturity and availability status of Redpill features

=head1 VERSION

Version v0.1.0

=cut

our $VERSION = 'v0.1.0';

my $progname = path($0)->basename;

our %OPT = ();
my @OPT = ();

=head1 SYNOPSIS

    feature-check [ --help | --version ]

    feature-check [OPTION...]

=head1 DESCRIPTION

B<feature-check> is a command-line tool
to parse and examine a set of Redpill features,
and print a summary on standard output.

Usability of each feature is evaluated
based on coverage and embedded annotations of its documentation.

=head1 OPTIONS

=head2 General

=over 16

=item B<-h>, B<--help>

print help message and exit

=item B<--man>

print manual and exit

=item B<-v>, B<--version>

print version and copyright information and exit

=back

=cut

push @OPT, qw(
    verbose
    help|h
    man
    version|v
);

GetOptions( \%OPT, @OPT ) or pod2usage(2);

pod2usage(1) if ( $OPT{help} );
pod2usage(-exitval => 0, -verbose => 2)  if ($OPT{man});
if ( $OPT{version} ) { version(); exit 0; }

pod2usage( join "\n", map {"Unknown argument: $_"} @ARGV )
    if @ARGV;

my $BASEDIR = path('../..');

my @TARGET = qw(executive user expert);
readonly \@TARGET;

my @MATURITY = qw(unusable buggy incomplete usable good);
readonly \@MATURITY;

use enum qw(
    UNUSABLE=0 BUGGY INCOMPLETE USABLE GOOD
    EXECUTIVE=0 USER EXPERT
);

my %DOCFILE = (
    ADMIN    => EXPERT,
    INTRO    => USER,
    OVERVIEW => EXECUTIVE,
    README   => EXECUTIVE,
    SETUP    => EXPERT,
    USE      => USER,
);
readonly \%DOCFILE;

my $threshold = USABLE;
$log->info("acceptance threshold: $MATURITY[$threshold]");

my $graph = Graph::Easy::Parser->from_text('graph { flow: east; }');
$graph->catch_messages(1);
my $root = 'features';

my $featureref = path("$BASEDIR")->visit( \&feature );

#use DDP; p $featureref if $log->is_debug;

my ( @row, %node );

$node{$root} = $graph->add_node($root);

for my $feature ( sort keys %$featureref ) {
    my @target = @{ $featureref->{$feature}{target} };

    next unless $featureref->{$feature}{maturity} >= $threshold;

    push @row, [ $feature, map { join ', ', sort keys %{ $target[$_]{docs} } if $target[$_]{maturity} >= $threshold } EXECUTIVE..EXPERT ]
        if $featureref->{$feature}{maturity} >= $threshold;

    next if defined $node{$feature};

    $node{$feature} = undef;
}

for my $feature ( sort keys %node ) {

    next if defined $node{$feature};

    if ( $feature =~ /^([^-]+).*\K-(?=[^-]+$)/ and defined $node{$`} and !defined $node{$feature} ) {
        ( undef, $node{$feature} ) = $graph->add_edge( $node{$`}, $feature );
        $node{$feature}->set_attribute( 'label',  $' );
    }
    else {
        ( undef, $node{$feature} ) = $graph->add_edge( $node{$root}, $feature );
    }
}

my $table = Term::Table->new(
    header => [ 'feature', @TARGET ],
    rows   => \@row,
);

say $_ for $table->render;

print $graph->as_boxart();

$log->error($_) for $graph->errors();
$log->warn($_) for $graph->warnings();

sub feature {
    my ($path, $state) = @_;
    my ( $feature, $docs, $maturity );

    return unless $path->is_dir;
    return if $path->basename =~ qr/\.$/;

    $feature = $path->basename;
    $log->trace("found feature: $feature");

    $docs = $path->visit( \&docfile );

    for my $target (EXECUTIVE..EXPERT) {
        my $maturity;

        if ( exists $docs->{$target} ) {
            $state->{$feature}{target}[$target]{docs} = $docs->{$target};
            $maturity = max map { $_->{maturity} } values %{ $docs->{$target} };
        }
        else {
            $maturity = UNUSABLE;
        }

        $state->{$feature}{target}[$target]{maturity} = $maturity;
        $log->debug("resolved feature $feature target $target maturity: $maturity");
    }

    if ( exists $state->{$feature}{target}[EXECUTIVE]{docs} && exists $state->{$feature}{target}[EXECUTIVE]{docs}{README} ) {
        $maturity = $state->{$feature}{target}[EXECUTIVE]{maturity};
    }
    elsif ( INCOMPLETE < $state->{$feature}{target}[EXECUTIVE]{maturity} ) {
        $maturity = INCOMPLETE;
    }
    else {
        $maturity = $state->{$feature}{target}[EXECUTIVE]{maturity};
    }

    $state->{$feature}{maturity} = $maturity;
    $log->warningf('skipping %s feature: %s', $MATURITY[$maturity], $feature)
        if $maturity < $threshold;
}

sub docfile {
    my ($path, $state) = @_;
    my ( $doc, $category, $content, $maturity );

    return unless $path->is_file;
    $doc = $path->basename('.md');
    return if $path->basename eq $doc;
    return unless exists $DOCFILE{$doc};
    $category = $DOCFILE{$doc}
        // return;

    $content = $path->slurp_utf8;
    if ( $content =~ qr/\bFIXME\b/ ) {
        $maturity = BUGGY;
    }
    elsif ( $content =~ qr/\bTODO\b/ ) {
        $maturity = INCOMPLETE;
    }
    else {
        $maturity //= USABLE;
    }

    $state->{$category}{$doc}{maturity} = $maturity;
    $log->trace("found docfile: $doc", { maturity => $maturity });
}


=head1 MATURITY

=head2 Documentation file

A documentation file is considered broken
if it contains any B<FIXME> annotations,
or otherwise considered unfinished
if it contains any B<TODO> annotations.

=head2 Targeted documentation

A targeted documentation,
for each of the Redpill targets B<executive>, B<user> and B<expert>,
is as mature as the most mature of their files,
or unusable if none exist for the target.

=head2 Feature

A feature is as mature as the most mature targeted documentation,
except it is at most unfinished
unless documentation complies with standard-readme specification.

=head1 ENVIRONMENT

=over 6

=item NO_COLOR

If defined, will disable color.
Consulted before COLOR.

=item COLOR

Can be set to 0 to explicitly disable colors.
The default is to use color when connected to a terminal.

=item LOG_LEVEL
=item QUIET
=item VERBOSE
=item DEBUG
=item TRACE

Used to emit varying details about discoveries to STDERR.
See L<Log::Any::Adapter::Screen> for more details.

=item LOG_PREFIX

The default formatter groks these variables.
See B<formatter> in L<Log::Any::Adapter::Screen> for more details.

=back

=encoding UTF-8

=head1 AUTHOR

Jonas Smedegaard C<< <dr@jones.dk> >>

=head1 COPYRIGHT AND LICENSE

  Copyright 2021-2022  Jonas Smedegaard

This program is free software:
you can redistribute it and/or modify it
under the terms of the GNU Affero General Public License
as published by the Free Software Foundation,
either version 3, or (at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY;
without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
See the GNU Affero General Public License for more details.

You should have received a copy
of the GNU Affero General Public License along with this program.
If not, see <https://www.gnu.org/licenses/>.

=cut

1;