Prolog lambda-calculus-to-js translator #2

lc.prolog

:- op(1030, xfx, is).
:- op(1045, yfx, @).
:- op(1040, yfx, after).
:- op(1050, xfy, to).
:- op(1175, xfy, in).

compile 
    --> simplify
    ,   toJS
    ,   !
    ,   flip(name)
    .

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

simplify(X, Y)
    :-  desugar(X, Y)
    ,   !
    .

desugar(Name is Value in Context, Result)
    :-  Name =.. [F, X | Xs]
    ,   desugar(F is ([X | Xs] to Value) in Context, Result)
    .

desugar(Name is Value in Context, (Name -> Context1) @ Value1)
    :-  maplist(desugar, [Context, Value], [Context1, Value1])
    .

desugar(F @ X, G @ Y)
    :- maplist(desugar, [F, X], [G, Y])
    .

desugar(Xs to E, Result)
    :-  Xs = [_ | _]
    ,   reverse(Xs, Args)
    ,   desugar(E, E1)
    ,   foldl(abstract, Args, E1, Result)
    .

desugar(X to E, Result)
    :-  atom(X)
    ,   desugar([X] to E, Result)
    .

desugar(Expr, Result)
    :-  Expr =.. [F, X | Xs]
    ,   \+ member(F, [., to])
    ,   maplist(desugar, [X | Xs], Ys)
    ,   foldl(apply, Ys, F, Result)
    .

desugar(extern(X), extern(X)).

desugar(X, X)
    :-  atomic(X)
    .

apply(X, F, F @ X).
abstract(X, E, X -> E).

toS --> maplist(toJS).

toJS(F @ X, JS)
    :-  toS([F, X], [G, Y])
    ,   append(["(", G, ") (", Y, ")"], JS)
    .

toJS(X -> E, JS)
    :-  toS([E], [E1])
    ,   name(X, Y)
    ,   append(["function (", Y, ") { return ", E1, " }"], JS)
    .

toJS(extern(Literal), Literal).

toJS --> name.

dump(Prog)
    :-  compile(Prog, JS)
    ,   writeln(JS)
    .

test
    :-  dump(
            plus              is extern("function (x) { return function(y) { return x + y } }")
        in  recursive(f)      is extern("(function(x) { return x(x) }) (function(x) { return f(function(y) { return (x)(x)(y) }) })")
        in  cons(x, xs, n, s) is s(x, xs)
        in  nil(n, s)         is n
        in  after(f, g, x)    is f(g(x))
        in  reduce(zero, add) is recursive(recur to 
                list to 
                    list(zero, x to 
                        add(x) after recur))

        in  map(f)            is reduce(nil, cons after f)
        in  sum               is reduce(0, plus)
        
        in  sum(map(plus(1), cons(1, cons(2, cons(3, nil)))))
    ).

lc1.prolog

:- op(1030, xfx, is).
:- op(1025, fx, fix).
:- op(1010, xfy, $).
:- op(1005, yfx, o).
%% :- op(1040, yfx, after).
:- op(1020, xfy, to).
:- op(1175, xfy, in).

%% simplify(X, _) :-
%%     writeln(simplify - X),
%%     fail.

simplify(Decl is Body in Context, Result) :-
    Decl =.. [Name | Args],
    not_empty_list(Args),
    simplify(Name is Args to Body in Context, Result).

simplify(Name is Body in Context, Name is Body1 in Context1) :-
    atom(Name),
    maplist(simplify, 
        [Body,  Context], 
        [Body1, Context1]).

simplify(fix X, fix Result) :-
    simplify(X, Result).

simplify(F $ X, G $ Y) :-
    maplist(simplify, [F, X], [G, Y]).

simplify(Arg1 to Arg2 to Body, Result) :-
    arg_append(Arg1, Arg2, Args),
    simplify(Args to Body, Result).

simplify(Args to Body, Safe to Body1) :-
    arg_append(Args, [], Safe),
    simplify(Body, Body1).

simplify(Funcall, Result) :-
    Funcall =.. [Name | Args],
    not_empty_list(Args),
    maplist(simplify, Args, Args1),
    foldl(apply_fun, Args1, Name, Result).

simplify(Other, Other).

apply_fun(X, F, F $ X).

not_empty_list([_|_]).

arg_append(A, B, C) :-
    flatten([A, B], C).

pp(Something is Args to Body in Somewhere, Result) :-
    name(Something, Name),
    maplist(pp, [Args, Body, Somewhere], [A, B, S]),
    flatten([Name, "\tis ", A, " to ", B, "\n", S], Result).

pp(Something is Body in Somewhere, Result) :-
    name(Something, Name),
    maplist(pp, [Body, Somewhere], [B, S]),
    flatten([Name, "\tis ", B, "\n", S], Result).

pp(Args to Body, Result) :-
    maplist(pp, [Args, Body], [A, B]),
    flatten(["\\", A, " to ", B], Result).

pp(F $ X, R) :-
    unapply(F $ X, Chain),
    maplist(pp, Chain, Parts),
    join(Parts, Mess),
    flatten(["(", Mess, ")"], R).

pp(fix X, R) :-
    pp(X, Y),
    flatten(["fix ", Y], R).

pp(List, Result) :-
maplist(pp, List, PPd),
    join(PPd, Text),
    flatten(["[", Text, "]"], Result).

pp -->
    term_to_atom,
    name.

unapply(F $ X, R) :-
    unapply(F, G),
    append(G, [X], R).

unapply(F, [F]).

load(X, X, X).

join([X], [X]).

join([X | Xs], R) :-
    join(Xs, T),
    flatten([X, " ", T], R).

pp(X) :-
    writeln(X).

ascribe_fixity([] to Body, [] to Body).
ascribe_fixity([X | Xs] to Body, [X: N | Ys] to Body) :-
    count(X, Xs to Body, N),
    ascribe_fixity(Xs to Body, Ys to Body).

count


test :-
    P = (
            cons(head, tail, zero, add) is add(head, tail)
        in  nil(add, zero)              is zero
        in  f o g                       is x to f(g(x))
        in  foldl(zero, add) is fix go to
                list to list(zero, 
                    x to
                        add(x) o go
                )
        in  sum is foldl(0, plus)
        in  sum $ cons(1, nil)
    ),
    simplify(P, S),
    pp(S, R),
    name(T, R),
    writeln(T),
    !.