Lambda calculus 2 js translator, written on Prolog.

lc.prolog

%% Here and below, lc = en.wikipedia.org/wiki/Lambda_calculus, the simplest
%% functional language possible.

%% There are two languages in use here: weak lc & rich lc.

%% The only allowed constructions for weak are
%%   X -> B, "function (X) { return B }" where X is a name and B is valid weak lc
%%   F @ X,  "F(X)"                      where F & X are valid lc
%%   Term    any term                    where Term is name or integer

%% The rich one is extension to weak, it allows:
%%   [X, Y, ...] -> B as a shorthand to X -> Y -> ... -> B
%%   F(X, Y, ...)     as a shorthand to F @ X @ Y

%% The goal is to get maximum optimization with agressive erasure.

%%% operator priorities/associativity, for nice look

:- op(506, xfy, ;).   % A; B; C == A; (B; C)
:- op(505, xfy, =).   
:- op(504, xfy, ->).  % A -> B -> C == A -> (B -> C)
:- op(503, yfx, @).   % A @ B @ C == (A @ B) @ C
:- op(502, xfy, $).   % A $ B $ C == A $ (B $ C)
:- op(501, xfy, o).   % A o B o C == A o (B o C)

%%% turn weak lc into a rich lc

%% transforming nil & cons into a list literal (disabled for now)
% enrich(nil, []).
% enrich(cons @ X @ Xs, [Y | Ys]) :-
%     enrich(X,  Y),
%     enrich(Xs, Ys).

%% pack all arguments into a list
% x -> y -> z ==> [x, y] -> z'
enrich(Expr, List -> Body) :-
    lambda(Expr, List -> End),
    enrich(End, Body).

%% pack the chain of applications into nicer-looking form
% f @ x @ y ==> f'(x', y')
enrich(Expr, Result) :-
    toList(Expr, [F | Args]),
    maplist(enrich, Args, Enriched),

    ( % if first applicant is an atom. we could form f(x, y) block
      ( atom(F)
      , Result =.. [F | Enriched]
      )

      % otherwise, form a new chain from enriched points
    ; foldl(unwrap, Enriched, F, Result)
    ).

%% all other things are leaved as they are
enrich(X, X).

%%% pack a lambda

%% the body is another lambda, like this: x -> y -> z
lambda(A -> X, [A | List] -> End) :-
    lambda(X, List -> End).

%% the body is other
lambda(A -> X, [A] -> End) :-
    lambda(X, End).

lambda(A, A).

app -->
    toList,
    flip(=..).

%%% f @ x @ y ==> [f, x, y]
toList(F @ X, L) :-
    toList(F, G),
    append(G, [X], L).

toList(F, [F]).

flip(P, X, Y) :- call(P, Y, X).

%%% revert from weak ls to rich one

%% unpack list literals
%%
%% will bind to the last "nil" or "cons" declared!
enfeeble([], nil).
enfeeble([X | Xs], cons @ X @ Ys) :- 
    enfeeble(Xs, Ys).

%% for application, descent onto both sides
enfeeble(F @ X, F1 @ X1) :-
    maplist(enfeeble, [F, X], [F1, X1]).

%% change right-aligned apply operator into left aligned one
enfeeble(F $ X, R) :-
    enfeeble(F @ X, R).

%% unwrap composition operator (disabled)
%% the declaration in the rlc source code does the same thing with
%% a proper optimizations
%%
%% enfeeble(F o G, tmp -> F1 @ (G1 @ tmp)) :-
%%     maplist(enfeeble, [F, G], [F1, G1]).

%% [x, y] -> z ==> x -> y -> z
enfeeble(List -> Body, Result) :-
    reverse(List, Args),
    enfeeble(Body, Inner),
    foldl(unlambda, Args, Inner, Result).

%% x -> z ==> x -> z'
enfeeble(Item -> Body, Item -> Result) :-
    enfeeble(Body, Result).

%% f(x, y) ==> f @ x @ y
enfeeble(F, Result) :-
    F =.. [G | Args],
    maplist(enfeeble, Args, List),
    foldl(unwrap, List, G, Result).

enfeeble(A, A).

unlambda(A, B, A -> B).

unwrap(A, F, F @ A).

%----------------------------------------------------------------------------%

%%% apply strategy while it does any changes

%% apply strat, if it did any changes - continue
whileProductive(Strategy, I, O) :-
    call(Strategy, I, T),
    I \= T,
    whileProductive(Strategy, T, O).

%% return the input otherwise
whileProductive(_, I, I).

%----------------------------------------------------------------------------%

%%% apply any of strategies passed while possible to any ast point

%% start tracking shadowed names
traverse(Catchers) -->
    traverse1(Catchers, []).

%% if any strategy fires, take its result & repeat
traverse1(Catchers, Shadow, A, C) :-
    member(Catcher, Catchers),
    call(Catcher, Shadow, A, C).

%% if its a lambda, descent into body
traverse1(Catchers, Shadow, X -> B, X -> R) :-
    traverse1(Catchers, [X | Shadow], B, R).
    %% (B \= R, traverse1(Catchers, Shadow, X -> R, F)
    %% ; F = R).

%% if its an app, descent into both sides
traverse1(Catchers, Shadow, F @ X, G @ Y) :-
    maplist(traverse1(Catchers, Shadow), [F, X], [G, Y]).
    %% ((F \= G); (X \= Y)),
    %% traverse1(Catchers, Shadow, G @ Y, R).

%% if its a terminal, leave its be
traverse1(_, _, A, A).

%%% null strategy

doNothing(_, _, _) :- fail.

%----------------------------------------------------------------------------%

%%% this strategy inlines all linear functions, when they got applied to smth
inlineLinear(_, (X -> B) @ A, R) :-
    linear(X -> B),
    inject(A, X, B, R).

%%% function is linear by its first arg, when it uses it 0 or 1 time

linear(X -> B) :-
    count(X, B, N),
    !,
    N < 2.

%%% calculate usage count

count(X, X,      1).
count(_, Y,      0) :- atom(Y); integer(Y).
count(X, X -> _, 0).
count(X, _ -> B, N) :- count(X, B, N).
count(X, F @ Y, N)  :-
    count(X, F, A),
    count(X, Y, B),

    N is A + B.

%%% the substitution mechanizm

inject(Val, X, X,      Val).
inject(_,   _, Y,      Y)      :- atom(Y); integer(Y).
inject(_,   X, X -> B, X -> B).
inject(Val, X, Y -> B, Y -> C) :- inject(Val, X, B, C).
inject(Val, X, F @ Y,  G @ Z)  :-
    inject(Val, X, F, G),
    inject(Val, X, Y, Z).

%----------------------------------------------------------------------------%

%%% inlines all calls to the previously defined linear functions
%%% could possibly cause cycles on mutual recursion

inlineCalls(Shadow, Name, X -> Body) :-
    atom(Name),
    \+ member(Name, Shadow),
    clause(Name = X -> Body),
    linear(X -> Body).

%%% inlines all applications of lambdas

%% effectively eval's small programs
inlineAll(_, (X -> B) @ Arg, R) :-
    inject(Arg, X, B, R).
%----------------------------------------------------------------------------%

%% special case of inlineAll
consume(_, (X -> B) @ X, B).

%----------------------------------------------------------------------------%

etaReduce(_, X -> B @ X, B) :-
    count(X, B, N),
    !,
    N = 0.

%----------------------------------------------------------------------------%

%%% mocks a definition
%%% useful when testing "inlineCalls" optimization in repl

mockDef(Name = Def) :-
    retractall(clause(_)),
    enfeeble(Def, Real),
    asserta(clause(Name = Real)).

%%% compile the program

%% stores program as predicate clause(Name = Body)
compile(Name = A; B) :-
    compileValue(A, T, R),
    retractall(clause(Name = _)), % forgets previous version
    asserta(clause(Name = T)),
    js(Name = T, JS),
    format("~s~n~n", [JS]),
    !,
    compile(B).

%% the last object (ocaml/lisp style entry-point) is printed
compile(A) :-
    compileValue(A, T, R),
    js(it = T, JS),
    format("~s~n", [JS]).

%%% converts rich ls to weak, optimizes it, enrichs back

compileValue(A, T, R) :-
    enfeeble(A, F),
    optimize(F, T),
    enrich(T, R).

%%% calls two most powerful optimizations

optimize -->
    whileProductive(traverse([inlineCalls, inlineAll, etaReduce])).

%%% JS backend

js(Name = It, Out) :-
    toJs(It, JS),
    show(Name, JS, Out).

show(Name) -->
    flatten,
    append([Name, =]),
    unwords.

unwords -->
    maplist(name),
    maplist(append(" ")),
    flatten.

%% toJS(PoorLC, JS)
%
% converts poor language to js
%
toJs(X, X) :- integer(X).

toJs(Op, Name) :-
    member(Op - Name, [(+) - plus, (-) - minus, (*) - mult, '/' - div]).

toJs(X, X) :- atom(X).

%% native(+,a,b) ==> (a + b)
%
toJs(Op @ X @ Y, ['(', X1, Op, Y1, ')']) :- 
    member(Op, [+, -, *, '/']),
    toJs(X, X1), 
    toJs(Y, Y1).

%% a @ b ==> a(b)
%
toJs(F @ X, [F1, '(', X1, ')']) :- 
    toJs(X, X1), 
    toJs(F, F1).

%% x -> m ==> function (x) { return m }
%
toJs(X -> M, [function, '(', X, ')', '{', return, M1, '}']) :- 
    toJs(M, M1).

%%% test case

:- compile(
    plus   = 'function (x) { return function (y) { return x + y } }';

    o      = [f, g, x] -> f(g(x));

    nil    =                 [cons, nil] -> nil;
    cons   = [head, tail] -> [cons, nil] -> cons(head, tail(cons, nil));

    append = [list, tail] -> list(cons, tail);
    sum    = [list]       -> list([x, y] -> x + y, 0);

    sum o append([1, 2, 3])
).

out.prolog

:- compile(
    plus   = 'function (x) { return function (y) { return x + y } }';

    o      = [f, g, x] -> f(g(x));

    nil    =                 [cons, nil] -> nil;
    cons   = [head, tail] -> [cons, nil] -> cons(head, tail(cons, nil));

    append = [list, tail] -> list(cons, tail);
    sum    = [list]       -> list([x, y] -> x + y, 0);

    sum o append([1, 2, 3])
).

> it = function ( x ) { return ( 1 + ( 2 + ( 3 + x ( plus ) ( 0 ) ) ) ) }