File Coverage

blib/lib/Language/FP.pm

Criterion	Covered	Total	%
statement	221	285	77.5
branch	56	138	40.5
condition	8	24	33.3
subroutine	53	57	92.9
pod	3	34	8.8
total	341	538	63.3

#!/usr/bin/env perl
package Language::FP;
use Parse::RecDescent;
use Regexp::Common;

require Exporter;
@EXPORT = qw/fp_eval/;
@EXPORT_OK = qw/perl2fp fp2perl bottom BOTTOM/;
%EXPORT_TAGS = (':all' => [@EXPORT_OK, @EXPORT]);
@ISA = qw(Exporter);

$VERSION = 0.03;

sub BOTTOM () {			# the universal bad value
    if ($::FP_DEBUG =~ /b/) {
	use Carp 'confess';
	confess("Bottom!");
    }
    undef
}

sub bottom {			# check for bottom
    (@_ > 0 && !defined($_[0])) ? 1 : 0
}

sub numeric {			# check for 2 integer args
    return ($_[0] =~ /$RE{num}{real}/o) && ($_[1] =~ /$RE{num}{real}/o);
}

######################################################################
## Parser

##############################
# Debugging

sub info {			# pretty debugging output.
    my ($pack, $fn, $line, $subr) = caller 1;
    $subr =~ s/^.*:://;
    print STDERR "[$subr] ", @_, "\n";
}

sub Dparse {			# parse-time debugging output
    goto &info if $::FP_DEBUG =~ /p/;
}

sub Drun {			# run-time debugging.
    goto &info if $::FP_DEBUG =~ /r/;
}

##############################
# Utilities

# XXX: this shouldn't be needed.  It makes  behave the same as X
# when passed as an argument list.  Single-element lists and scalar
# values aren't the same kind of thing, but we're trying to pretend as
# if they are.  Otherwise, perl functions called from FP will all have
# to take array-refs.
sub as_array($) {
    my $a = shift;
    if (ref $a eq 'ARRAY') {
	@$a;
    } else {
	$a;
    }
}

# XXX: this is the disgusting inverse of as_array
sub to_arrayref {
    if (@_ == 1) {
	return shift;
    } else {
	return [@_];
    }
}

sub call_it {			# call a coderef, with verbosity
    my $f = shift;
    Drun "Calling $f (@_)";
    my @res = $f->(@_);
    Drun "-> (@res)";
    @res;
}

sub term {			# create a typed parse-tree node.
    my $type = shift;
    return { type => $type, val => [@_] };
}

##############################
# Symbol lookup.

# Note: we need to do a bit of magic here to look up functions and
# variables in both Language::FP and the calling package.

sub findsym {			# look up a function
    my ($sym, $type) = @_;
    if (ref $sym eq $type) {
	return $sym;
    }
    my ($where, $thing);
    foreach ('Language::FP', pkg()) {
	my $x = $_.'::'.$sym;
	if (defined($thing = *{$x}{$type})) {
	    $where = $x;
	    last;
	}
    }
    if (wantarray) {
	($thing, $where);
    } else {
	$thing;
    }
}

######################################################################
## The parser

my $P = undef;
sub get_parser {
    return $P if $P;
    $P = new Parse::RecDescent <<'EOG' or die "Can't create parser!";

{
use Regexp::Common;
    BEGIN {
	no strict 'refs';
	foreach (qw|term findsym|) {
	    *{__PACKAGE__.'::'.$_} = \&{'Language::FP::'.$_};
	}
    }
}

thing:	  'val'  id_undef '=' application
		{ $return = term 'val', @item{qw(id_undef application)} }
	| 'def'  id_undef '=' termlist
		{ $return = term 'def', @item{qw(id_undef termlist)} }
	| application
		{ $return = $item[1];1; }
	| /\s*/
	|

application: termlist ':'  data
		{ $return = term 'application', @item{qw(termlist data)}; }
	| data
		{ $return = $item[1]; }

termlist: 'while'  complist termlist
		{ $return = term 'while', @item{qw(complist termlist)} }
 	| complist '->'  complist ';' termlist
		{ $return = term 'if', @item[1,4,6] }
	| complist
		{ $return = $item[1];1; }
	|

complist:
		{ $return = term 'compose', @{$item[1]} }

func:	  'bu'  func data
		{ $return = term 'bu', @item{qw(func data)} }
	| '/' func
		{ $return = term 'insert', $item{func} }
	| '@'  func
		{ $return = term 'forall', $item{func} }
	| '('  termlist ')'
		{ $return = $item{termlist} }
	| '['   ']'
		{ $return = term 'distribute', @{$item[3]} }
	| '`'  data
		{ $return = term 'constant', $item{data} }
	| sfunc
		{ $return = $item[1];1; }
	| id
		{ $return = $item[1];1; }
	|

data:	  datum
		{ $return = term 'data', $item[1] }
	|

datum:	  '<'  datum(s?) '>'
		{ $return = $item[3];1; }
	| /$RE{num}{real}/o
		{ $return = $item[1];1; }
 	| /$RE{num}{int}/o
		{ $return = $item[1];1; }
	| /$RE{quoted}/o
		{ $return = substr($item[1], 1, length($item[1]) - 2);1; }
	| m{[a-rt-zA-Z_][\w\d]*}
	    {
		no strict 'refs';
		# XXX: actually interpolate variables during parse.
		$return = findsym($item[1], 'ARRAY') || undef;
	}
	|

sfunc:	  /\d+/
		{ $return = term 'sfunc', $item[1]; }

id_undef:  m{[a-zA-Z_][\w\d]*}
		{ $return = term 'id_undef', $item[1]; }

id:	  m{[a-zA-Z_][\w\d]*}
		{ $return = term 'id', $item[1];1; }
	| m{([!<>=]=) | [+*/<>-] | ([gln]e) | ([gl]t) | eq}x
		{ $return = term 'op', $item[1]; }

EOG
    $P;
}

######################################################################
## Builtin functions (for both compilers).

# FP is supposed to be "bottom-preserving".  In other words, once a
# single operaation fails, it taints all results that depend on it.
# The only way to recover from this is to explicitly recognize the
# "bottom" condition using the bottom() test.

my %op_guts;
BEGIN {
    %op_guts = (
## List ops #####
# first/last element of list
hd 	=> '@_ ? $_[0] : BOTTOM',
hdr 	=> '@_ ? $_[-1] : BOTTOM',
# rest of list
tl 	=> '@_ ? @_[1..$#_] : BOTTOM',
tlr 	=> '@_ ? @_[0..$#_ - 1] : BOTTOM',
len 	=> 'return BOTTOM if bottom @_; scalar @_',
'reverse' => 'reverse @_',
# append
apndl 	=> '($_[0], @{$_[1]})',
apndr 	=> '(@{$_[0]}, $_[1])',
# Rotate
rotl 	=> '@_ ? @_[1..$#_,0]  : ()',
rotr 	=> '@_ ? @_[$#_, 0..$#_ - 1] : ()',
# Catenate
cat 	=> 'map { as_array $_ } @_',
## Logical ops #####
'and' 	=> '$_[0] &&  $_[1]',
'or' 	=> '$_[0] || $_[1]',
'not' 	=> '!$_[0]',
## Other ops #####
id 	=> '@_',
out 	=> 'print STDERR perl2fp(@_), "\n"; @_',
iota 	=> '1 .. $_[0]',
atom 	=> '@_ == 1 && ref($_[0]) eq "SCALAR"',
null 	=> '@_ == 0',
## "shaping" list-ops #####
distl 	=> q{
    my ($a, $b) = @_;
    return BOTTOM unless !bottom($a) && ref $b eq 'ARRAY';
    map { [$a, $_] } @$b;
},

distr 	=> q{
    my ($a, $b) = @_;
    return BOTTOM unless !bottom($b) && ref $a eq 'ARRAY';
    map { [$_, $b] } @$a;
},

trans 	=> q{
    my @ret;
    return () unless @_;
    my $len = scalar @{$_[0]};
    foreach (@_[1..$#_]) {
	return BOTTOM unless ref $_ eq 'ARRAY' && @$_ == $len;
    }
    for (my $i = 0; $i < $len; $i++) {
	push @ret, [ map { $_->[$i] } @_ ];
    }
    @ret;
},
);
}

######################################################################
## Closure-based "Compiler"

sub defun {			# 'def' X '=' ...
    my ($name, $val) = @_;
    no strict 'refs';
    *{pkg().'::'.$name} = $val;
    Drun "Defined function $name";
    'ok';
}

sub defvar {			# 'val' X '=' ...
    my ($name, $val) = @_;
    no strict 'refs';
    @{pkg().'::'.$name} = as_array $val;
    Drun "Defined value $name";
    'ok';
}

sub do_bu {			# bu (i.e. currying)
    my ($f, $o) = @_;
    Dparse "using $f($o, ...)";
    return sub {
	no strict 'refs';
	Drun "bu $f ($o, @_)";
	call_it($f, $o, @_);
    };
}

sub compose {			# '.' operator
    my @funcs = @_;
    Dparse "using (@funcs)";
    return sub {
	no strict 'refs';
	Drun "compose (@funcs)";
	foreach my $f (reverse @funcs) {
	    @_ = call_it($f, @_);
	}
	@_;
    };
}

sub distribute {		# '[...]' list-of-functions
    my @xs = @_;
    Dparse "using (@xs)";
    return sub {
	no strict 'refs';
	Drun "distribute (@xs) : (@_)";
	map { to_arrayref call_it $_, @_ } @xs;
    }
}

sub ifelse {			# 'a -> b ; c' construct
    my ($if, $then, $else) = @_;
    Dparse "if $if then $then else $else";
    return sub {
	# XXX: having to call this in array context sucks, but is necessary.
	Drun "if $if then $then else $else";
	my ($test) = call_it $if, @_;
	if (bottom($test)) {
	    BOTTOM;
	} elsif ($test) {
	    call_it $then, @_;
	} else {
	    call_it $else, @_;
	}
    };
}

sub awhile {			# 'while x y'
    my ($while, $do) = @_;
    Dparse "while ($while) $do";
    return sub {
	Drun "while ($while) $do -> (@_)";
	my $test;
	while (!bottom($test = (call_it $while, @_)[0])) {
	    if (!$test) {
		Drun "END while ($while): (@_)";
		return @_;
	    }
	    @_ = call_it $do, @_;
	}
	# Bottom.
	BOTTOM;
    }
}

sub forall {			# '@' operator, i.e. map
    my $f = shift;
    Dparse "using $f";
    return sub {
	no strict 'refs';
	Drun "forall $f (@_)";
	map { to_arrayref call_it $f, as_array $_ } @_;
    };
}

sub insert {			# '/' operator, i.e. reduce
    my $f = shift;
    Dparse "using $f";
    return sub {
	no strict 'refs';
	Drun "insert $f (@_)";
	return () unless @_;
	my $r = $_[0];
	return BOTTOM if bottom($r);
	foreach (@_[1..$#_]) {
	    $r = (call_it $f, $r, $_)[0];
	    return BOTTOM if bottom($r);
	}
	$r;
    }
}

sub constant {			# constant '`' operator
    my $x = shift;
    Dparse $x;
    return sub {
	Drun "constant $x";
	as_array $x;
    };
}

sub apply {			# ':' operator
    my ($func, $args) = @_;
    return $func->(as_array $args);
}

my %ops = ();			# symbol table for binary operators
sub make_binary_ops {
    return if keys %ops > 0;
    # Build binary operator functions.
    foreach my $f (qw|+ - * / ** == != < > <= >=|) {
	$ops{$f} = eval qq{sub {
 			return BOTTOM unless numeric(\@_);
			\$_[0] $f \$_[1]
		}
		} || die $@;
    }
}

local $::fp_caller = 'Language::FP';
sub pkg {			# package in which to bind functions
    $::fp_caller;
}

my %compile =
(
 val => \&defvar,
 def => \&defun,
 application => \&apply,
 while => \&awhile,
 if => \&ifelse,
 compose => \&compose,
 bu => \&do_bu,
 insert => \&insert,
 forall => \&forall,
 distribute => \&distribute,
 constant => \&constant,
 sfunc => sub {
     my $x = $_[0] || die "sfunc($#_): (@_)";
     sub { $_[$x - 1] }
 },
 id => sub {
     my $ret = findsym($_[0], 'CODE');
     unless ($ret) {
	 warn "Undefined function $_[0].";
	 return \&BOTTOM;
     }
     $ret;
 },
 data => sub { @_ },
 id_undef => sub { shift },
 op => sub {
     confess "unknown operator '$_[0]'" unless exists $ops{$_[0]};
     return $ops{$_[0]};
 }
);

sub closure_compile {		# internal compiler function
    my $tree = shift;
    if (ref $tree ne 'HASH') {
	return $tree;
    }
    my $type = $tree->{type};
    if (exists $compile{$type}) {
	my @args = map { closure_compile($_) } @{$tree->{val}};
	return $compile{$type}->(@args);
    } else {
	die "Can't handle $tree (type = $type)";
    }
}

sub CLOSURE_compile {		# external compiler function
    make_binary_ops;
    closure_compile(@_);
}

######################################################################
# The "Big Heinous Eval" compiler.

=for comment

Since Perl's sub calls are slow, I decided to try compiling FP def's
down to single, heinous Perl functions.  As I suspected, this turns
out to be much faster than the other implementation, though debugging
is much more of a challenge.

Each code generating function should return an expression that will
evaluate to its result in list context, and that has enough parens
around it to avoid confusing Perl's parser.

The functions should use temporaries where necessary to avoid
evaluating any of its arguments more than once.  These temporaries
cannot be references, since the arguments generally won't be real
arrays, but expressions producing them.

=cut

sub seq($) {			# Turn a sequence into an expression
    return '(do {
'.$_[0].'
})';
}

my $gen = 0;
sub gensym {			# yep.
    if (wantarray) {
	return map { $_.'_'.++$gen } @_;
    } else {
	return $_[0].'_'.++$gen;
    }
}

my %bhe_compile =
(
 val => sub {
     my ($name, $val, $rhs) = @_;
     $name = bhe_compile($name, undef);
     eval '@'.pkg()."::$name = ".bhe_compile($val, $rhs).";'ok';";
     if ($@) {
	 warn "Compilation error in $name: $@" if $@;
	 BOTTOM;
     } else {
	 q{'ok'};
     }
 },
 def => sub {
     my ($name, $val, $rhs) = @_;
     my $BODY = bhe_compile($val, $rhs);
     my $NAME = pkg().'::'.bhe_compile($name, undef);
     Dparse "\n---\n", $body, "\n---\n";
     eval "sub $NAME { $BODY }";
     if ($@) {
	 warn "Compilation error in $NAME: $@" if $@;
	 BOTTOM;
     } else {
	 q{'ok'};
     }
 },
 application => sub {
     my ($func, $args, $rhs) = @_;
     my $arg = bhe_compile($args, undef);
     return bhe_compile($func, $arg);
 },
 while => sub {
     my ($while, $do, $rhs) = @_;
     my ($test, $res) = gensym '$WHILE', '@WHILE';
     my $WHILE = bhe_compile($while, $res);
     my $DO = bhe_compile($do, $res);
     seq <
my $res = $rhs;
while (my $test = ($WHILE)[0]) {
	$res = $DO;
	return BOTTOM if bottom($res);
    }
     $res;
END
 },
 if => sub {
     my ($if, $then, $else, $rhs) = @_;
     my $x = gensym '@IF';
     my ($IF, $THEN, $ELSE)
	 = map { bhe_compile($_, $x) } ($if, $then, $else);
     seq <
my $x = $rhs;
if (($IF)[0]) {
    $THEN;
} else {
    $ELSE;
}
END
 },
 compose => sub {
     my $rhs = pop;
     my @funcs = @_;
     my $ret = $rhs;
     while (my $x = pop @funcs) {
	 $ret = bhe_compile($x, $ret);
     }
     $ret;
 },
 bu => sub {
     my ($f, $a, $rhs) = @_;
     my $A = bhe_compile($a, undef);
     return bhe_compile($f, "($A, $rhs)");
 },
 insert => sub {
     my ($f, $rhs) = @_;
     my ($r, $x, $xs) = gensym '$INSERT', '$INSERT', '@INSERT';
     my $DOIT = bhe_compile($f, "($r, $x)");
     return seq <
my $xs = $rhs;
if ($xs) {
    my $r = shift $xs;
    foreach my $x ($xs) {
	$r = ($DOIT)[0];
	return Language::FP::BOTTOM if Language::FP::bottom($r);
    }
    $r;
} else {
    ();				# nothing to insert
}
END
},
 forall => sub {
     my ($f, $rhs) = @_;
     my $v = gensym '@FORALL';
     my $body = bhe_compile($f, $v);
     seq <
map {
    my $v = Language::FP::as_array(\$_);
    Language::FP::to_arrayref($body)
} $rhs
ENDS
 },
 distribute => sub {
     my $rhs = pop;
     my $args = gensym '@DISTRIBUTE';
     my $ret = "my $args = $rhs;\n(";
     $ret .= join ",\n\t", map {
	 'Language::FP::to_arrayref('.bhe_compile($_, $args).')'
     } @_;
     seq ($ret . ');');
 },
 constant => sub { return bhe_compile(shift, undef) },
 sfunc => sub {
     my ($x, $rhs) = @_;
     --$x;			# FP indices are one-based.
     "(($rhs)[$x])";
 },
 id => sub {
     my ($f, $rhs) = @_;
     my ($code, $fullname) = findsym($f, 'CODE');
     unless ($code) {
	 warn "Undefined function $f.";
	 return 'return BOTTOM';
     }
     unless ($fullname) {
	 warn "Anonymous sub not supported\n";
	 return 'return BOTTOM';
     }
     return '&{'.$fullname.'}('.$rhs.')';
 },
 data => sub {
     use Data::Dumper;
     pop;			# get rid of rhs.
     return 'Language::FP::as_array('.seq(Dumper(to_arrayref @_)).')';
 },
 id_undef => sub { shift },
 op => sub {
     my ($op, $rhs) = @_;
     my $res = gensym 'OP';
     seq "my \@$res = $rhs; \$$res\[0] $op \$$res\[1]";
 }
);

sub BHE_compile {		# bootstrap function for BHE
    my $compiled = bhe_compile(@_, '@_');
    Dparse "---\n$compiled\n---\n";
    my @ret = eval $compiled;
    warn $@ if $@;
    @ret;
}

sub bhe_compile {		# Internal BHE compile function
    my $tree = shift;
    my $rhs = shift;
    if (ref $tree ne 'HASH') {
	# Terminals should never call bhe_compile
	die;
    }
    my $type = $tree->{type};
    if (exists $compile{$type}) {
	return $bhe_compile{$type}->(@{$tree->{val}}, $rhs);
    } else {
	die "Can't handle $tree (type = $type)";
    }
}

######################################################################
## Exportables:

sub import {
    Language::FP->export_to_level(1, @_);

    # XXX: maybe consider autoloading these?

    # Build op-functions.
    while (my ($f, $b) = each %op_guts) {
	*{$f} = eval qq{ sub { return BOTTOM if bottom(\@_); $b }};
	die "$f: $@" if $@;
    }
    1;
}

sub perl2fp {
    my @ret;
    foreach (@_) {
	if (ref eq 'ARRAY') {
	    push @ret, '<'.perl2fp(@$_).'>';
	} elsif (ref) {
	    die "Expecting ARRAY, got ".ref;
	} elsif (/$RE{num}{int}/o || /$RE{num}{real}/o) {
	    push @ret, $_;
	} elsif (defined) {
	    push @ret, qq{"$_"};
	} else {
	    push @ret, '_|_';
	}
    }
    join(' ', @ret);
}

sub fp2perl {
    my $str = shift;
    return to_arrayref($P->data($str));
}

sub fp_eval {
    local $::fp_caller = caller;
    my $p = get_parser;
    if (@_ == 1) {
	use Data::Dumper;
	my $parsed = $P->thing(shift);
	unless ($parsed) {
	    warn "Parse error";
	    return undef;
	}
 	if ($::FP_DEBUG =~ /C/) {
	    return [CLOSURE_compile($parsed)];
 	} else {
	    return [BHE_compile($parsed)];
 	}
    }

    my %o = @_;
    my $in = $o{in} || 'STDIN';
    my $out = $o{out} || 'STDOUT';
    while (<$in>) {
	chomp;
	my $res = $P->thing($_);
	unless ($res) {
	    warn;
	    next;
	}
	print $out perl2fp($res), "\n";
    }
}

1;

__END__