proof-of-concept

#!/usr/local/bin/perl6
use v6;

use App::Pls;
use JSON::Tiny;

# RAKUDO: Workarounds for the core not being visible from inside roles.
our &_open      = &open;
our &_slurp     = &slurp;
our &_to-json   = &to-json;
our &_from-json = &from-json;

role FileBackend {
    has $.filename;
    has Bool $!dirty;

    method set-state-of($project, State $state) {
        callsame;
        $!dirty = True;
    }

    method save-to-file() {
        if $!dirty {
            _open($.filename, :w).say(_to-json(%.projects));
        }
        $!dirty = False;
    }

    method load-from-file() {
        %.projects = $.filename ~~ :e ?? _from-json(_slurp($.filename))
                                      !! ();
        $!dirty = False;
    }
}

class POC::ProjectsState is App::Pls::ProjectsState::Hash does FileBackend {
}

class POC::Ecosystem does App::Pls::Ecosystem does FileBackend {
    has %.projects is rw;
    has $!loaded-projects-file = False;

    method project-info(Str $project --> Project) {
        # This is *so* nice!
        unless $!loaded-projects-file++ {
            self.load-from-file;
        }
        die "No such project: $project"
            unless %!projects.exists($project);
        my %info = %.projects{$project};
        %info<name> = $project;
        return %info;
    }
}

sub run-logged($command) {
    my $logfile = "pls.log";
    if $command ~~ /^'cd '(\S+)/ && $0 -> $subdir {
        $logfile = '../' ~ $logfile
            for $subdir.comb(/ ['\\/' || <-[/]> ]+ /); #'
    }
    my $result = run "$command > $logfile 2>&1";
    # RAKUDO: The actual result should have a boolean value opposite that of
    #         the numeric value, but that's not so in Rakudo yet, and
    #         seemingly for two reasons: (1) &run doesn't create those
    #         integers with overloaded boolifications, and (2) even if it did
    #         something like `5 but False` evaluates to true in and 'if'
    #         statement.
    if !$result {
        unlink "pls.log";
    }
    return !$result;
}

sub relative-to($dir, $command) {
    "cd $dir && $command";
}

sub announce-start-of(Str $action, Str $project) {
    my $participle = "$action.ucfirst()ing";
    my $message = $participle ~ " " x (11 - $participle.chars) ~ "$project ";
    print $message, "." x 39 - $message.chars, ' ';
}

# RAKUDO: Can't type $result with Result, due to [perl #75370]
sub announce-end-of(Str $action, $result) {
    say $result == success ?? "[done]" !! "[FAIL]";
}

class POC::Fetcher does App::Pls::Fetcher {
    # RAKUDO: Can't use '--> Result' after a 'where' block
    # RAKUDO: Havn't tracked down why, but can't use a multi here to
    #         dispatch on $project<home>
    method fetch($project) {
        die "Not able to fetch non-github projects yet, sorry :/"
            unless $project<home> eq 'github';
        if "cache" !~~ :e {
            run-logged "mkdir cache";
        }
        if "cache" !~~ :d {
            die "Cannot proceed, cache inexplicably isn't a directory";
        }
        my $target-dir = "cache/$project<name>";
        if $target-dir ~~ :e {
            run-logged("rm -rf $target-dir");
        }
        my $command
            = sprintf 'git clone git://github.com/%s/%s.git %s',
                      $project.<auth>, $project.<name>, $target-dir;
        my $result = run-logged( $command ) ?? success !! failure;

        return $result;
    }
}

class POC::Builder does App::Pls::Builder {
    method build($project --> Result) {
        my $target-dir = "cache/$project<name>";
        if "$target-dir/Makefile" !~~ :e {
            my $binary = 'perl6';
            my $cwd = qx[pwd].chomp ~ '/' ~ $target-dir;

            if "$cwd/lib" !~~ :e {
                return success;
            }
            elsif "$cwd/lib" !~~ :d {
                return failure;
            }

            # The grep is needed because 'find' prints a final newline, so
            # there'll be an empty-string element at the end of the list.

            my @module-files
                = grep { $_ },
                  split "\n",
                  qqx[cd $cwd; find lib -name \*.pm -or -name \*.pm6];

            if !@module-files || @module-files[0].lc ~~ /'no such file'/ {
                return success;
            }

            # To know the best order of compilation, we build a dependency
            # graph of all the modules in lib/. %usages_of ends up containing
            # a graph, with the keys (containing names modules) being nodes,
            # and the values (containing arrays of names) denoting directed
            # edges.

            my @modules = map { path-to-module-name($_) }, @module-files;
            my %usages_of;
            for @module-files -> $module-file {
                my $fh = open($module-file, :r);
                my $module = path-to-module-name($module-file);
                %usages_of{$module} = [];
                for $fh.lines() {
                    if /^\s* 'use' \s+ (\w+ ['::' \w+]*)/ && $0 -> $used {
                        next if $used eq 'v6';
                        next if $used eq 'MONKEY_TYPING';

                        %usages_of{$module}.push(~$used);
                    }
                }
            }

            sub path-to-module-name($path) {
                $path.subst(/^'lib/'/, '').subst(/\.pm6?$/, '')\
                     .subst('/', '::', :g);
            }

            sub module-name-to-path($module-name) {
                my $pm = 'lib/' ~ $module-name.subst('::', '/', :g) ~ '.pm';
                $pm ~~ :e ?? $pm !! $pm ~ '6';
            }

            my @order;

            # According to "Introduction to Algorithms" by Cormen et al.,
            # topological sort is just a depth-first search of a graph where
            # you pay attention to the order in which you get done with the
            # dfs-visit() for each node.

            my %color_of = @modules X=> 'not yet visited';
            for @modules -> $module {
                if %color_of{$module} eq 'not yet visited' {
                    dfs-visit($module);
                }
            }

            sub dfs-visit($module) {
                %color_of{$module} = 'visited';
                for %usages_of{$module}.list -> $used {
                    if %color_of{$used} eq 'not yet visited' {
                        dfs-visit($used);
                    }
                }
                push @order, $module;
            }

            # The intended effect of the below loop is to put as many module
            # paths on each line as possible, breaking when necessary, and
            # indenting nicely.

            my @sources = map { &module-name-to-path($_) }, @order;
            my $sources = 'SOURCES=';
            my $line-length = 0;
            for @sources -> $source {
                $line-length += $source.chars + 1;
                if $line-length > 65 {
                                   # SOURCES=
                    $sources ~= "\\\n        ";
                    $line-length = $source.chars + 1;
                }
                $sources ~= $source ~ ' ';
            }
            $sources.=trim-trailing;

            my $makefile = open "$cwd/Makefile", :w;
            $makefile.say(qq[PERL6=$binary]);
            $makefile.say(qq[PERL6LIB='$cwd/lib']);
            $makefile.say(q[]);

            $makefile.say($sources);

            $makefile.say(qq[
PIRS=\$(patsubst %.pm6,%.pir,\$(SOURCES:.pm=.pir))

.PHONY: test clean

all: \$(PIRS)

%.pir: %.pm
\tenv PERL6LIB=\$(PERL6LIB) \$(PERL6) --target=pir --output=\$@ \$<

%.pir: %.pm6
\tenv PERL6LIB=\$(PERL6LIB) \$(PERL6) --target=pir --output=\$@ \$<

clean:
\trm -f \$(PIRS)

test: all
\tenv PERL6LIB=\$(PERL6LIB) prove -e '\$(PERL6)' -r --nocolor t/]);

            sub directory-of($file) {
                $file.subst(/ '/' <-[/]>*? $ /, '');
            }

            sub write-install($extension?) {
                for @sources -> $s {
                    my $file = defined $extension
                                ?? $s.subst(rx{\.pm6?$}, '.' ~ $extension)
                                !! $s;
                    # Can't use 'install -D' like we originally did,
                    # because Mac OS X has that flag as '-d'.
                    my $directory = directory-of($file);
                    $makefile.say("\tmkdir -p ~/.perl6/$directory");
                    $makefile.say("\tinstall $file ~/.perl6/$file");
                }
            }

            $makefile.say(q[]);
            $makefile.say(q[install: all]);
            write-install('pir');

            $makefile.say(q[]);
            $makefile.say(q[install-src:]);
            write-install();

            $makefile.close;
        }
        unless run-logged( relative-to $target-dir, "make" ) {
            return failure;
        }

        return success;
    }
}

class POC::Tester does App::Pls::Tester {
    method test($project --> Result) {
        my $target-dir = "cache/$project<name>";
        if "$target-dir/Makefile" !~~ :e {
            return failure;
        }
        unless run-logged( relative-to $target-dir, "make test" ) {
            return failure;
        }

        return success;
    }
}

class POC::Installer does App::Pls::Installer {
    method install($project --> Result) {
        my $target-dir = "cache/$project<name>";
        if "$target-dir/Makefile" !~~ :e {
            return failure;
        }
        unless run-logged( relative-to $target-dir, "make install" ) {
            return failure;
        }
        return success;
    }
}

role POC::FetchAnnouncer {
    method fetch($project --> Result) {
        announce-start-of('fetch', $project<name>);
        my $result = callsame;
        announce-end-of('fetch', $result);
        return $result;
    }
}

role POC::BuildAnnouncer {
    method build($project --> Result) {
        announce-start-of('build', $project<name>);
        my $result = callsame;
        announce-end-of('build', $result);
        return $result;
    }
}

role POC::TestAnnouncer {
    method test($project --> Result) {
        announce-start-of('test', $project<name>);
        my $result = callsame;
        announce-end-of('test', $result);
        return $result;
    }
}

role POC::InstallAnnouncer {
    method install($project --> Result) {
        announce-start-of('install', $project<name>);
        my $result = callsame;
        announce-end-of('install', $result);
        return $result;
    }
}

sub MAIN(Bool :$force) {
    my $projstate = POC::ProjectsState.new(:filename("poc-projects.state"));
    $projstate.load-from-file;

    my $core = App::Pls::Core.new(
        :projects($projstate),
        :ecosystem( POC::Ecosystem.new(:filename("poc-projects.list")) ),
        :fetcher(   POC::Fetcher.new()   does POC::FetchAnnouncer   ),
        :builder(   POC::Builder.new()   does POC::BuildAnnouncer   ),
        :tester(    POC::Tester.new()    does POC::TestAnnouncer    ),
        :installer( POC::Installer.new() does POC::InstallAnnouncer ),
    );

    # RAKUDO: Below line required because non-supplied named Bool
    #         comes in as Any(). [perl #73680]
    my Bool $_force = ?$force;
    $core.install("json", :force($_force));
    $projstate.save-to-file();
}