package Language::INTERCAL::Interface::Line;

# line-oriented user interface

# This file is part of CLC-INTERCAL

# Copyright (c) 2007-2008 Claudio Calvelli, all rights reserved.

# CLC-INTERCAL is copyrighted software. However, permission to use, modify,
# and distribute it is granted provided that the conditions set out in the
# licence agreement are met. See files README and COPYING in the distribution.

use strict;
use vars qw($VERSION $PERVERSION);
($VERSION) = ($PERVERSION = "CLC-INTERCAL/UI-Line INTERCAL/Interface/Line.pm 1.-94.-2") =~ /\s(\S+)$/;

BEGIN { $ENV{PERL_RL} = 'Gnu'; } # doesn't work with any other ReadLine package

use Carp;
use Term::ReadLine;
use Language::INTERCAL::Exporter '1.-94.-2';
use Language::INTERCAL::GenericIO '1.-94.-2', qw($stdread $stdwrite);

sub new {
    @_ == 2
	or croak "Usage: Language::INTERCAL::Interface::Line->new(SERVER)";
    my ($class, $server) = @_;
    $server or croak "Must provide SERVER";
    my $term = Term::ReadLine->new('CLC-INTERCAL')
	or die "Term::ReadLine: $!\n";
    my $outfile = $term->OUT;
    if ($outfile) {
	$outfile = new Language::INTERCAL::GenericIO('FILE', 'r', $outfile);
    } else {
	$outfile = $stdread;
    }
    my $wobj = bless {
	prompt => 'Intercalc',
	buffer => '',
	server => $server,
	term => $term,
    }, 'Language::INTERCAL::Interface::Line::WOBJ';
    my $infile = new Language::INTERCAL::GenericIO('OBJECT', 'w', $wobj);
    my $line = bless {
	term => $term,
	stdread => $outfile,
	stdwrite => $infile,
	wobj => $wobj,
    }, $class;
    my $attribs = $term->Attribs;
    $attribs->{attempted_completion_function} = sub {
	my ($ignore, $text, $start, $end) = @_;
	my $code = $line->{complete};
	return ('') unless $code;
	my $base = substr($text, $start, $end - $start);
	$text = substr($text, 0, $end);
	my $map = sub { $_[0] };
	if ($text =~ /(?:^|\s)(\w+)$/) {
	    if ($1 eq lc($1)) {
		$map = sub { lc($_[0]) };
	    } elsif ($1 eq uc($1)) {
		$map = sub { uc($_[0]) };
	    }
	}
	my @list = map { $base . $map->($_) } $code->($text);
	if (! @list) {
	    $attribs->{rl_completion_suppress_append} = 1;
	    $attribs->{completion_suppress_append} = 1;
	    return '';
	}
	if (@list == 1) {
	    my ($word) = @list;
	    if (ref $word) {
		# special for "attempt filename completion"
		return ();
	    }
	    if ($word !~ /^\w+$|\s\w+$/) {
		$attribs->{rl_completion_suppress_append} = 1;
		$attribs->{completion_suppress_append} = 1;
	    }
	    return $word;
	}
	return '', @list;
    };
    $attribs->{rl_basic_word_break_characters} = '';
    $attribs->{basic_word_break_characters} = '';
    $attribs->{rl_basic_quote_characters} = '';
    $attribs->{basic_quote_characters} = '';
    $attribs->{rl_completer_word_break_characters} = '';
    $attribs->{completer_word_break_characters} = '';
    $attribs->{rl_special_prefixes} = '';
    $attribs->{special_prefixes} = '';
    $line;
}

END {
    eval { Term::ReadLine->deprep_terminal };
}

sub has_window { 0 }
sub is_interactive { 1 }

sub is_terminal {
    $stdwrite->is_terminal;
}

sub run {
    croak "Line mode interface should never enter run()";
}

sub start {
    croak "Line mode interface should never enter start()";
}

sub stdread {
    @_ == 1 or croak "Usage: LINE->stdread";
    my ($line) = @_;
    $line->{stdread};
}

sub stdwrite {
    $stdwrite;
}

sub getline {
    @_ == 2 or croak "Usage: LINE->getline(PROMPT)";
    my ($line, $prompt) = @_;
    my $wobj = $line->{wobj};
    local ($wobj->{prompt}) = $prompt;
    $line->{stdwrite}->write_text;
}

sub complete {
    @_ == 1 || @_ == 2 or croak "Usage: LINE->complete [(CALLBACK)]";
    my ($line, $code) = @_;
    $line->{complete} = $code;
    $line;
}

package Language::INTERCAL::Interface::Line::WOBJ;

sub write {
    my ($wobj, $size) = @_;
    my $res = substr($wobj->{buffer}, 0, $size, '');
    return $res if length $res == $size;
    $wobj->{buffer} = '';
    my $term = $wobj->{term};
    my $server = $wobj->{server};
    my $go = 1;
    my $nl = '';
    my $code = sub {
	($nl) = @_;
	$go = 0;
	$term->callback_handler_remove;
    };
    $term->callback_handler_install($wobj->{prompt}, $code);
    $server->file_listen(fileno(STDIN),
			 sub { $term->callback_read_char });
    while ($go) {
	$server->progress;
    }
    $server->file_listen_close(fileno(STDIN));
    $term->callback_handler_remove;
#    my $nl = $term->readline($wobj->{prompt}, $res);
    if (defined $nl) {
	$term->addhistory($nl);
	$nl .= "\n";
	$res = substr($nl, 0, $size, '');
	$wobj->{buffer} = $nl;
	return $res;
    } else {
	print "\n";
	return '';
    }
}

package Language::INTERCAL::Interface::Line::IN;

sub new {
    my ($class) = @_;
    bless \*STDIN, $class;
}

1;