Language::FP - think like Jonh Backus wants you to

  use Language::FP qw/perl2fp/;

  # Sum of the first 12 integers:
  my $sum = fp_eval '/+ . iota:12'
  print perl2fp($result);
  # prints '<78>'

  # Matrix-vector product:
  fp_eval 'def Ax = @(+ . @* . trans) . distr';
  my @mv = ([[1, 2], [3, 4]], [5, 6]);
  print perl2fp(fp_eval('Ax:' . perl2fp(@mv)));
  # prints '<17 39>'

  # Cross-language calls:
  print join ', ', Ax(@mv);
  # prints '17, 39'

  sub cubes { map { $_ ** 3 } @_ }
  print perl2fp(fp_eval 'cubes:<1 2 3>');
  # prints '<1 8 27>'

  fp_eval in => \*INPUT, out => \*OUTPUT;

  my @result = Language::FP::distl $x, @ys

  def totient = /+ . @((== . [1, `1] -> `1 ; `0) .
 	(while (> . [2, `0]) (< -> reverse ; id) . [2, -]))
 	. distl . [id, iota]

#!/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 <X> 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' <commit> id_undef '=' application
		{ $return = term 'val', @item{qw(id_undef application)} }
	| 'def' <commit> id_undef '=' termlist
		{ $return = term 'def', @item{qw(id_undef termlist)} }
	| application
		{ $return = $item[1];1; }
	| /\s*/
	| <error>

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

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

complist: <rightop: func '.' func>
		{ $return = term 'compose', @{$item[1]} }

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

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

datum:	  '<' <commit> 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]*}
	  <error?: Undefined variable "$item[1]"> <commit> {
		no strict 'refs';
		# XXX: actually interpolate variables during parse.
		$return = findsym($item[1], 'ARRAY') || undef;
	}
	| <error>

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.

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 <<END;
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 <<END;
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 <<END;
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 <<ENDS;
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__

# one-liner version of the above, for cut-and-paste:
# def totient = /+ . @((== . [1, `1] -> `1 ; `0) . (while > . [2, `0] (< -> reverse ; id) . [2, -])) . distl . [id, iota]