perl6 better repl

repl.p6

#!/usr/bin/env perl6
use MONKEY;
use nqp;

module TREPL {
### STATIC DEFINITIONS ###
role Descriptive[Str $desc] {
	has Str $.Desc = $desc;
}

role REPL {
	method send-line(Str $) { * }
	method send-all(Str $) { * }
}

class Commands is rw {
	has Callable %!registered{Str};

	method with-command(Str:D $line, &block) {
		if $line ~~ /^^ \;(.+) $$/ and my @full-command = $0.Str.split: ' ' and @full-command[0] ~~ %!registered {
			%!registered{@full-command[0]}(self, @full-command[1..*])
		} else {
			&block($line)
		}
	}
	method register(Str:D $name, &callback where .signature.ACCEPTS: \(Commands, Array[Str])) {
		%!registered{$name} = &callback;
	}
	method version {
		sub infix:<~~~>($a, $b) { $a ~ "\n" ~ $b };
		say 'trepl version 0. https://github.com/aearnus/'
		~~~ "running the language { $*PERL.gist } on { $*PERL.compiler.gist }"
		~~~ 'type `;help` for help, or type `;quit` or `;exit` to leave.'
		~~~ '';
	}
	method help {
		self.version;
		say 'Commands:';
		%!registered.map: { say "   ;{ .key } -- { .value.Desc }" };
	}
}

class SingleFile {
	has $.file is rw;
	has Str $.name is rw;
	has Str $.update-hash is rw = '';
	
	sub really-cheap-hash(buf8 $data --> Str) {
		constant $massive-prime = 29996224275833;
		constant $out-len = 32;
		my buf8 $out = buf8.new(1..$out-len);
		for ($massive-prime <<%<< $data).List {
			$out[$_ % $out-len] = $_;
		}
		$out.List.fmt('%03x', '')
	}
	method load(Str $filename, REPL $r is rw) {
		$.name = $filename;
		$.file = open $filename, :r orelse fail $_;
		self.reload: $r
	}
	method unload { $.file.close }
	method reload(REPL $r is rw) {
		$.file.seek: 0;
		# the below method for checking if the file changed is kinda silly
		# but we don't have a platform agnostic way to check modification date
		# so, this works, thus we use it anyway.
		given really-cheap-hash($.file.read(1_000_000_000)) {
			when $!update-hash {
				# the file hasn't updated, do nothing
				say "file $.name (hash { $_.comb[^8].join }...) not updated.";
			}
			default {
				# the file updated, reload it into our environment
				say "file $.name (hash { $_.comb[^8].join }...) updated. (re)loading...";
				$!update-hash = $_;
				$.file.seek: 0;
				try {
					$r.send-all($.file.slurp);
					CATCH {
						.Str.say
					}
				}
			}
		}
		$.file.seek: 0;
	}
}

class FileWatch {
	has REPL $.repl is rw is required;
	has SingleFile %.files{Str};

	method load(Str $filename) {
		my $file = SingleFile.new;
		$file.load: $filename, $!repl orelse .say.return;
		%.files{$filename} = $file;
		"loaded $filename into the REPL".say;
	}
	method unload(Str $filename) {
		with %.files{$filename}:delete {
			say "unloading file $filename";
			.unload;
		} else {
			say "file $filename not loaded, cannot unload"
		}
	}
	method reload {
		say 'reloading all loaded files...';
		%.files>>.reload(self);
		say 'done reloading files.';
	}
	method loaded {
		say 'currently loaded files:';
		%.files.map: { say "file { .key } (hash { .value.update-hash.comb[^8].join })" };
	}
}

class LineHistory {
	has Str @!hist;
}

class PerlAsyncWrapper does REPL is DEPRECATED {
	has Proc::Async $!perl;
	has Commands $.cmds is rw;
	
	submethod BUILD {
		$!perl = Proc::Async.new: :w, '/usr/bin/env', 'perl6', '--repl-mode=interactive';
		# some oddness going on here: the minor repl seems to discard the
		# first line that it is sent through the tap. so, we do some cheaty things
		# to get around that: we send a blank line then the banner line
		$!perl.stdout.lines.tap: sub (Str $out-line) {
			#"DEBUG: $_".say;
			# skip the first line that says "To exit type 'exit' or '^D'"
			once { return }
			given $out-line {
				# if this is a line of input
				when / ^ \> \h* $ / { self!handle-ready-for-input }
				# if our input was echoed back
				when / ^ \> (.+) $ / { }
				default { "=> $out-line".say }
			}
		}
	}
	method begin(Commands $cmds --> Promise:D) {
		$.cmds = $cmds;
		say 'loading minor Perl6 interpreter, from /usr/bin/env perl6';
		my $promise = $!perl.start;
		await $!perl.ready;
		self.send-line: "'minor Perl6 interpreter loaded.'.say";
		return $promise;
	}	
	method send-line(Str $line) {
		# the minor interpreter does not respond to anything without a few trailing newlines.
		# i don't want to ask why.
		$!perl.say: "$line\n";
	}

	method !handle-ready-for-input {
		start {
			'trepl> '.print;
			my Str $in = get;
			$.cmds.with-command: $in.lc, {
				self.send-line: $in;
			}
		}
	}
}

class PerlNQPWrapper does REPL is rw {
	has $!compiler = nqp::getcomp('perl6');
	has $!save_ctx;

	submethod merge-contexts(Mu \ctx1, Mu \ctx2) {
		# unfortunately, we can't iterate through lexpads in normal perl6
		# since we cannot create an nqp-level block. so, this is all useless.

		# gratefully, setting :interactive(1) in eval seems to do the trick.
		# so, disregard every further comment for anything but educational purposes.
		
		# this is based off of SET_BLOCK_OUTER_CTX in nqp/Actions.nqp
		# for some reason, setting outer_ctx isn't calling this function properly.
		# so, we manually merge the contexts between each execution.
		# we use $ctx1 as the "before" and $ctx2 as the "after",
		# meaning we use the contents of $ctx2 in order to append to $ctx1
		#my $pad2 := nqp::ctxlexpad(ctx2);
		#unless nqp::isnull($pad2) {
		#	for nqp::hash(|$pad2) {
				#my Str $name = ~$_;
				#ctx1.bindlex($name, 0);
		#		.say;
		#	}
		#}
		ctx1 := ctx2;
		ctx1;
	}
	
	# $!compiler.eval calls $*CTXSAVE.ctxsave
    method ctxsave(*@args --> Nil) {
        $*MAIN_CTX := nqp::ctxcaller(nqp::ctx());
        $*CTXSAVE := 0;
	}
	
	# used for sending blocks of code. these should be completed
	# before they get sent to the repl. _this can bubble up an exception!_
	method send-all(Str $code) {
		$!save_ctx := nqp::ctx() if not nqp::defined($!save_ctx);
		my $*CTXSAVE := self;
		my $*MAIN_CTX := Nil;	
		$!compiler.eval($code, :outer_ctx($!save_ctx), :interactive(1));
		if $*MAIN_CTX {
			$!save_ctx := self.merge-contexts($!save_ctx, $*MAIN_CTX);
		}
	}

	# used for sending single lines, with completion
	method send-line(Str $code) {
		$!save_ctx := nqp::ctx() if not nqp::defined($!save_ctx);
		my $output;
		my $*CTXSAVE := self;
		my $*MAIN_CTX := Nil;	
		try {
			$output := $!compiler.eval($code, :outer_ctx($!save_ctx), :interactive(1));
			CATCH {
				# these two can be thrown if more input is needed.
				# in this case, we do something very odd and fishy:
				# for some reason, they represent a truthy value of
				# input-incomplete as an empty hash. this is probably
				# going to change at some point, and seems really odd
				# to me, so we go around that and just catch the errors
				# ourselves. this seems to be more reliable anyway.
				when X::Syntax::Missing | X::Comp::FailGoal {
					$output := nqp::hash();
					'     >> '.print;
					self.send-line($code ~ get);
					return;
				}
				
				default {
					'error:'.say;
					.say;
				}
			}
		}
		if $*MAIN_CTX {
			$!save_ctx := self.merge-contexts($!save_ctx, $*MAIN_CTX);
		}
		say "==> { $output.gist }" with $output;
		say "--> { $output.gist }" if $output ~~ Any:U;
	}
}

### RUNTIME DEFINITIONS ###
our $history is export = LineHistory.new;	
our $perl = TREPL::PerlNQPWrapper.new;
our $cmds = Commands.new;
our $loaded-files = FileWatch.new: :repl($perl);
$cmds.register: 'help', -> $cs, @args { $cs.help } but Descriptive["Print out this help menu."];
$cmds.register: 'exit', -> $cs, @args { die } but Descriptive["Close the REPL."];
$cmds.register: 'quit', -> $cs, @args { die } but Descriptive["Close the REPL."];
$cmds.register: 'load', -> $cs, @args { $loaded-files.load: @args[0] with @args[0] } but Descriptive["Load a file into the REPL."];
$cmds.register: 'reload', -> $cs, @args { $loaded-files.reload } but Descriptive["Reload whatever files are loaded."];
$cmds.register: 'loaded', -> $cs, @args { $loaded-files.loaded } but Descriptive["List the currently loaded files."];
$cmds.register: 'unload', -> $cs, @args { $loaded-files.unload: @args[0] with @args[0] } but Descriptive["Unload a file from the REPL."];
$cmds.version;
}

### RUNTIME ###
loop {
	'trepl> '.print;
	my Str $in = get;
	die without $in;
	TREPL::<$cmds>.with-command: $in.lc, {
		TREPL::<$perl>.send-line: $in;
	}
}