#!/usr/bin/perl -w

# colorize output from listbas... *after* it's been converted to utf8
# with a8cat, including ANSI codes for reverse/normal video.

($SELF = $0) =~ s,.*/,,;

%colornames = (
		none => 0,
		red => 1,
		green => 2,
		yellow => 3,
		blue => 4,
		purple => 5,
		cyan => 6,
);

%colors = (
		numbers => 'red',
		commands => 'yellow',
		functions => 'purple',
		linenumbers => 'cyan',
		comments => 'blue',
		variables => 'none',
		operators => 'green',
		strings => 'red',
);

@commands = qw/
	END FOR NEXT READ DATA RESTORE LINE INPUT DEFSTR DEFINT DEFDBL DEFSNG
	OPTION DIM COMMON DEF LET RANDOMIZE GOTO GOSUB RETURN GO RUN IF
	ELSE THEN STOP CONT RESUME ERROR ON AFTER POKE WAIT MOVE LOAD SAVE
	VERIFY MERGE PRINT PRINT LIST AUTO DEL TRON TROFF RENUM OPEN CLOSE
	GET PUT NOTE LOCK UNLOCK KILL NAME GRAPHICS COLOR PLOT FILL SETCOLOR
	SOUND CLS DOS CLEAR NEW CLOAD CSAVE BASE TO SUB NOT STEP ALL USING
	RESERVE UPDATE OUTPUT APPEND AT PLM0 PLM2 PLM1 CHR0 CHR1 CHR2 AND
	OR XOR
/;

@functions = qw/
	TAB SPC AT SGN INT ABS FRE POS SQR LOG EXP COS SIN TAN ATN PEEK LEN STR
	VAL ASC CHR STATUS EOF LEFT RIGHT MID INSTR STRING VARPTR USR SCRN RND
	TIME INKEY ERR ERL STACK
/;

$cmdhash{$_}++ for @commands;
$funchash{$_}++ for @functions;

sub conf_file_name {
	my $home = $ENV{HOME};
	if(!defined $home) {
		warn "$SELF: HOME not set in environment, not reading config file\n";
		return undef;
	}
	return $home . '/.colorize-amsb.conf';
}

sub read_config {
	my $file = conf_file_name();
	return 1 if !defined $file; # caller won't create
	open my $fh, '<', $file or return 0; # not found, caller will create

	while(<$fh>) {
		chomp;
		s/#.*//;
		next if /^\s*$/;
		s/^\s*//;
		s/\s*$//;
		$_ = lc $_;
		if(/^([a-z]+)[^a-z]+([a-z]+)*$/) {
			my($k, $v) = ($1, $2);
			if(!defined $colors{$k}) {
				warn "$SELF: $file:$.: unknown color type '$k', ignoring\n";
			} elsif(!defined $colornames{$v}) {
				warn "$SELF: $file:$.: unknown color name '$v', ignoring\n";
			} else {
				$colors{$k} = $v;
			}
		} else {
			warn "$SELF: $file:$.: malformed line, skipping\n";
		}
	}

	close $fh;
}

sub create_config {
	my $file = conf_file_name();
	return unless defined $file;
	open my $fh, '>', $file or do {
		warn "$SELF: can't create $file: $!\n";
		return;
	};

	my $types = join(" ", sort keys %colors);
	my $names = join(" ", sort keys %colornames);

	print $fh <<EOF;
# colorize-amsb.conf

# lines with # are comments. blank lines are ignored.

# each line is "type = color", where valid types are:
#   $types
# and valid colors are:
#   $names

EOF

	for(sort keys %colors) {
		print $fh '#' . $_ . ' = ' . $colors{$_} . "\n";
	}

	close $fh;
}

sub is_cmd {
	return $cmdhash{$_[0]};
}

sub is_func {
	return $funchash{$_[0]};
}

sub is_punct {
	for($_[0]) {
		return 0 if length > 1;
		return 0 if /[\sA-Za-z0-9]/;
	}
	return 1;
}

sub is_varname {
	return $_[0] =~ /^[A-Z]/;
}

sub start_color {
	my $color = shift;
	my $colortype = $colors{$color} || die "invalid color type $color\n";
	my $colornum = $colornames{$colortype};
	die "invalid color name $color\n" unless defined $colornum;
	if($colornum) {
		print "\x1b[3" . $colornum . "m";
	}
}

sub end_color {
	print "\x1b[0m";
}

sub colorize {
	my $color = shift;
	my $text = shift;
	#warn "color $color, text '$text'\n";
	start_color($color) if $color;
	print $text;
	end_color if $color;
}

sub colorize_line {
	my $line = shift;

	# skip initial blank line (or really any blank lines)
	return unless length $line;

	# split on non-word characters, capturing the delimiters.
	# spliting this: 10 PRINT "HELLO":A=1.0E+10:END
	# ...gives this set of tokens:
	#   10
	#   <space>
	#   PRINT
	#   <space>
	#   "
	#   HELLO
	#   "
	#   :
	#   1
	#   .
	#   0E
	#   +
	#   10
	#   :
	#   END

	@toks = (split(/(\W)/, $line));

	# special case the line number
	my $tok = shift @toks;
	if($tok =~ /^\d+/) {
		colorize('linenumbers', $tok);
	} else {
		die "$SELF: no line number at line $., not LISTed AMSB?\n";
	}

	my $lasttok = '';
	my $lastcolor = 0;
	my $in_comment = 0;
	my $in_string = 0;

	# iterate over the rest of the tokens. kinda hairy, sorry.
	for my $tok (@toks) {
		my $color = 0;

		if($in_comment || $in_string) {
			$color = 0;
			if($in_string && $tok eq '"') {
				$in_string = 0;
				$color = 'operators';
			}
		} elsif($tok =~ /^REM|!|'/) {
			start_color('comments'); # rest of line
			$in_comment = 1;
		} elsif($tok eq '"') {
			$color = 'operators';
			$in_string = 1;
		} elsif($tok eq '#') {
			if($lastcolor eq 'variables') {
				# double-precision variable
				$color = 'variables';
			} else {
				# OPEN #, PRINT #, CLOSE #, etc
				$color = 'operators';
			}
		} elsif($tok eq '%') {
			# integer variable
			$color = 'variables';
		} elsif($tok eq '#' && $lastcolor eq 'variables') {
			# double-precision variable
			$color = 'variables';
		} elsif($tok eq '$') {
			# $ takes either the functions or variables color
			$color = $lastcolor;
		} elsif($tok eq '.') {
			# decimal point only appears in a number
			$color = 'numbers';
		} elsif(($tok eq '-' || $tok eq '+') && $lasttok =~ /^\d+E$/) {
			# scientific notation (entire number is the same color)
			$color = 'numbers';
		} elsif($tok eq '&') {
			# hex constant operator
			$color = 'numbers';
		} elsif($lasttok eq '&') {
			# hex constant argument
			$color = 'numbers';
		} elsif(is_cmd($tok)) {
			$color = 'commands';
		} elsif(is_func($tok)) {
			$color = 'functions';
		} elsif(is_punct($tok)) {
			$color = 'operators';
		} elsif(is_varname($tok)) {
			$color = 'variables';
		} else {
			$color = 'numbers';
		}

		# if $color == 0, colorize() just prints the token without escape codes.
		colorize($color, $tok);

		# if we just started a string, set the strings color.
		if($tok eq '"' && $in_string) {
			start_color('strings');
		}
		$lastcolor = $color;
		$lasttok = $tok;
	}

	# don't leave the text color enabled at the end of the line.
	end_color() if $in_comment || $in_string;
}

# main()
binmode(STDIN, ":utf8");
binmode(STDOUT, ":utf8");

if(!read_config()) {
	create_config();
}

while(<>) {
	chomp;
	colorize_line($_);
	print "\n";
}