package R2::Guile;

use POE;
use strict;

use Inline Guile => <<END;
  (define call/cc call-with-current-continuation)
  (define ARGV #f)
  (define set_ARGV (lambda (argv) (set! ARGV argv)))
  (define postback (lambda p
    (call/cc (lambda (k) ( (throw 'postback k p ))))))
  (define wrap-catcher (lambda (key k p)
    (cons k p)))
  (define catchwrap (lambda (expr)
    (catch #t (lambda () 
      (catch-postback expr))
      (lambda (key . args) (list 'guile 'thread_error (list (string-write (cons key args))))) )))
  (define catch-postback (lambda (expr)
    (catch 'postback (lambda () (apply (car expr) (cdr expr)) ) wrap-catcher )))
  (define string-write
    (lambda (obj) (call-with-output-string
      (lambda (port) (write obj port)))))
  (define r2-console (lambda (session)
    (do ((command-string #f) (command-results "Welcome to R2")) (#f)
      (set! command-string (postback session 'next_line command-results))
      (set! command-results
        (string-write
          (catch #t
            (lambda () (eval-string command-string))
            (lambda args (
              (if (eqv? (car args) 'postback)
                (apply throw args)
                (cons "ERROR:" args))))))))))
  (define reload-system (lambda () (perl-eval "exec \$0, \@ARGV")))
  (define postreturn (lambda (kont arg) (kont arg) ))
  (define session-spawn (lambda (package)
    (postback 'guile 'session_spawn package)))
  (define thread-exit (lambda ()
    (postback 'guile 'thread_exit)))
  (define new-thread (lambda args
    (postback 'guile 'new_thread args)))
  (define perl-load (lambda (package)
    (postback 'guile 'eval_perl (string-append "use " package))))
  (define perl-eval (lambda (string)
    (postback 'guile 'eval_perl string)))
END

set_ARGV(\@ARGV);

sub session_spawn {
	my $package = "$_[ARG1]";
	print "\r\nsession_spawn:".join(',',@_[ARG1 .. $#_])."\r\n";
	my @args = @_[ARG2 .. $#_];
	print "\r\nsession_args:".join(',',@args)."\r\n";
        for (0 .. $#args) {
                my $v = $args[$_];
                if (Guile::list_p($v)) {
			#print "Unpacking:";
			my @tmp = @{$v};
			#print "@tmp\n";
			$args[$_] = [ @tmp ];
		}
                print "\r\nElem ".$args[$_]." => ".(ref $args[$_])."\r\n";
        }
	my (@info) = $package->spawn(@args);
	$_[KERNEL]->yield('message', $_[ARG0], @info);
}

sub new_thread {
	#if ref($_[ARG1] ne 'Guile::SCM') {
	create_thread($_[KERNEL], $_[ARG1]);
	$_[KERNEL]->yield('message', $_[ARG0], $_[ARG1]);
}

sub create_thread {
	my ($kernel, $guile) = @_;
	my $r = catchwrap($guile);
	send_event($kernel,$r);
}

sub eval_perl {
	my $ret = eval $_[ARG1];
	$ret = $@ if $@; 
	$ret ||= 0;
	$_[KERNEL]->yield('message', $_[ARG0], $ret);
}

sub thread_exit { }

sub thread_error {
	warn ('Error in Guile thread', $_[ARG0..$#_]);
}

sub foo {
	$_[KERNEL]->yield('message', $_[ARG0], "Foo!");
}

sub message {
	my $r = postreturn($_[ARG0],$_[ARG1]);
	send_event($_[KERNEL],$r);
}

sub send_event {
	my ($kernel, $r) = @_;
	my ($kont, $session, $message, @args) = @$r;
	#my ($session, $message, @args) = @$a;
	#foreach (@args) {
	#	next unless Guile::list_p($_);
	#	$_ = @{$_};
	#}
	#print "$session $message\n";
	$kernel->post($session, $message, $kont, @args);
}

sub spawn {
	return POE::Session->create(
		package_states => [ 'R2::Guile' => [ '_start',
			'new_thread', 'session_spawn', 'message',
			'foo', 'eval_perl', 'thread_exit', 'thread_error' ] ] );
}

sub _start {
	$_[KERNEL]->alias_set('guile');
	create_thread($_[KERNEL], [ Guile::lookup('r2-start') ]);
}

sub R2::run {
	$poe_kernel->run();
}

1;