Lambda calculus interpreter (slow)

lang0.erl

-module(lang0).

-compile(export_all).

expression() ->
    parser:any([
        lambda(),
        application()
    ]).

lambda() ->
    parser:marked(lambda, 
        parser:entuple([
            parser:many1_tokens(parser:name()),

            parser:token("->"),

            parser:enlist([
                parser:return([]),
                
                parser:recuring(fun (_) -> expression() end)
            ])
        ])
    ).

application() ->
    parser:marked(app, 
        parser:many1_tokens(
            terminal()
        )
    ).

terminal() ->
    parser:any([
        parser:marked(var,   parser:name()),
        parser:marked(const, parser:number()),
        parser:inside(
            parser:token("("),
            parser:recuring(fun (_) -> expression() end),
            parser:token(")")
        )
    ]).

compile(Program) ->
    E = expression(),
    {ok, {PC, _}} = E(Program),
    dispatch([], PC).

print(Program) ->
    P = compile(Program),
    lc:print(P).

eval(Program) ->
    P = compile(Program),
    lc:eval(P).

dispatch(Stack, {app, List}) -> 
    lists:map(fun (X) -> dispatch(Stack, X) end, List);

dispatch(Stack, {lambda, Args, "->", [Body]}) ->
    Head = lists:map(fun (_) -> l end, Args),
    Head ++ dispatch(Args ++ Stack, Body);

dispatch(Stack, {var, Name}) ->
    N = number_of(Stack, Name),
    [var, N];

dispatch(Stack, {const, List}) ->
    list_to_integer(List).

number_of([X | List], X) -> 0;

number_of([_ | List], X) -> 1 + number_of(List, X).

lc.erl

-module(lc).

-compile(export_all).

test_program() ->
    [[l, l, l, [var, 2], [var, 0], [var, 1]],
      1,
      2,
     [l, l, [var, 1]]].

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

eval([l | Body]) ->
     [l | Body];

eval(List) when is_list(List) ->
    foldl1(
        fun (X, F) ->
            [l | Body] = eval(F),
            eval(substitute(Body, X))
        end,
        List);

eval(Other) -> Other.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

sink([l | Body]) -> Body;

sink(Other) -> Other.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

substitute([l | Body], X) -> [l | substitute(Body, push(X))];

substitute([var, 0], X) -> X;

substitute([var, N], _) -> [var, N - 1];

substitute(List, X) when is_list(List) ->
    lists:map(
        fun (Item) ->
            substitute(Item, X)
        end,
        List);

substitute(Other, _) -> Other.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

push([l | Body]) ->
     [l | push(Body)];

push([var, N]) -> [var, N + 1];

push(List) when is_list(List) ->
    lists:map(fun push/1, List);

push(Other) -> Other.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

foldl1(Fun, List) -> lists:foldl(Fun, hd(List), tl(List)).

log(Msg, Array) -> io:format(Msg ++ "\n", Array).

trace(Msg, Value) -> log(Msg, [Value]),
                     Value.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

print(Program) -> lists:flatten(print(0, Program)).

print(Name, [l | Body]) ->
    case is_lambda(Body) of
        true  -> [[$a + Name], " ", print(Name + 1, Body)];
        false -> [[$a + Name], " -> ", print(Name + 1, Body)]
    end;

print(_,    [var, N]) -> [$a + N];

print(Name,  List) when is_list(List) ->
    Result =
        lists:map(
            fun (X) ->
                Z = print(Name, X),

                case is_term(X) of
                     true  -> Z;
                     false -> ["(", Z, ")"]
                end
            end,
            List),
    foldl1(
        fun (X, Acc) ->
            [Acc, " ", X]
        end,
        Result);

print(_,     Other) -> io_lib:format("~p", [Other]).

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

is_term([var, _]) -> true;

is_term(T) -> not is_list(T).

is_lambda([l | _]) -> true;

is_lambda(_) -> false.

%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

selftest() ->
    eval(test_program()).

parser.erl

-module(parser).

-compile(export_all).

% Parser fun :: s() -> {'ok', {a(), s()}} | {'error', reason()}

return(A) -> fun (S) -> {ok, {A, S}} end.

what(Msg, P) -> 
    fun (S) ->
        {ok, {PS, S1}} = P(S),
        io:format("~s: ~p~n", [Msg, PS]),
        {ok, {PS, S1}}
    end.
    
char(C) ->
    fun (S) ->
        case S of
            [C | S1] -> {ok, {C, S1}};
            _        -> {error, {expected, C, but_found, S}}
        end
    end.

modify(P, Fun) ->
    fun (S) ->
        case P(S) of
            {ok, {D, S1}} -> {ok, {Fun(D), S1}};
            
            Error -> Error
        end
    end.
    
join(Plus, P) ->
    fun (C) ->
        modify(P, fun (D) -> Plus(C, D) end)
    end.
    
safe(Plus) ->
    fun
        (A, none) ->
            A;
        
        (none, B) ->
            B;
        
        (A, B) ->
            Plus(A, B)
    end.
    
list() -> 
    safe(fun(A, B) ->
             lists:flatten([A, B])
         end).
    
list_many() ->
    safe(fun(A, B) ->
             [A | B]
         end).
    
tuple() ->
    safe(
        fun    
            (A, {B, C, D, E, F, G, H}) ->
                {A, B, C, D, E, F, G, H};
                
            (A, {B, C, D, E, F, G}) ->
                {A, B, C, D, E, F, G};
                
            (A, {B, C, D, E, F}) ->
                {A, B, C, D, E, F};
                
            (A, {B, C, D, E}) ->
                {A, B, C, D, E};
                
            (A, {B, C, D}) ->
                {A, B, C, D};
                
            (A, {B, C}) ->
                {A, B, C};
                
            (A, B) ->
                {A, B}
        end).

single() ->
    safe(
        fun (A, B) -> 
            error(
                {parser_chain_must_return, single_expression, 
                 but_returns, at_least, A, 'and', B})
        end
    ).

% (>>=) :: Parser a s -> (a -> Parser a s) -> Parser a s
%
bind(P, FP) ->
    fun (S) ->
        case P(S) of
            {ok, {C, S1}} ->
                FPC = FP(C),
                FPC(S1);
                
            Error -> Error
        end
    end.
    
seq(Plus, PList) ->
    RPList = lists:reverse(PList),
    
    lists:foldl(
        fun (P, Acc) ->
            bind(P, join(Plus, Acc))
        end,
        hd(RPList),
        tl(RPList)).

one(Plist) -> seq(single(), Plist).

enlist(PList) -> seq(list(), PList).

enlist_plain(PList) -> seq(list_many(), PList).

entuple(PList) -> seq(tuple(), PList).

any([PLast]) ->
    fun (S) ->
        case PLast(S) of
            {ok, Result} -> {ok, Result};
            Error        -> Error
        end
    end;
    
any([P | PList]) ->
    fun (S) ->
        case P(S) of
            {ok, Result} -> {ok, Result};
            
            _ -> 
                Rest = any(PList),
                Rest(S)
        end
    end.
    
many(P) ->
    fun (S) ->
        case P(S) of
            {ok, {C, S1}} -> 
                Next = join(list_many(), many(P)),
                NextC = Next(C),
                NextC(S1);
            
            _ -> {ok, {[], S}}
        end   
    end.
    
many1(P) ->
    bind(P, join(list_many(), many(P))).

% TODO: Implement `is({PRED, ARGS})`-style.
%    
in_set({Name, Predicat}) ->
    fun 
        ([]) -> 
            {error, {expected, {being_in_set, Name}, but_found, 'EOF'}};
    
        ([C | S]) ->
            case Predicat(C) of
                true  -> {ok, {C, S}};
                
                false -> {error, {expected, {being_in_set, Name}, but_found, [C | S]}}
            end
    end.
    
is({'in_range', L, H}) -> 
    fun (C) ->
        (C >= L) and (C =< H)
    end;
    
is({'equal_to', D}) -> 
    fun (C) ->
        (C == D)
    end;
    
is({'or', Preds}) -> 
    fun (C) ->
        lists:any(fun (P) -> IP = is(P), IP(C) end, Preds)
    end;
    
is({'and', Preds}) -> 
    fun (C) ->
        lists:all(fun (P) -> IP = is(P), IP(C) end, Preds)
    end;
    
is({'not', P}) -> 
    fun (C) ->
        IP = is(P), 
        not (IP(C))
    end.
    
that(Pred) ->
    IP = is(Pred),
    fun 
        ([]) ->
            {error, {expected, Pred, but_found, 'EOF'}};
            
        ([C | S]) ->
            case IP(C) of
                true  -> {ok, {C, S}};
                
                false -> {error, {expected, Pred, but_found, [C | S]}}
            end
    end.
        
% Decorator.
%    
parsing(Expected, P) ->
    fun (S) ->
        case P(S) of
            {ok, Result} -> 
                {ok, Result};
            
            {error, {expected, E, but_found, S1}} ->
                {error, {expected, {Expected, means, E}, but_found, S1}}
        end
    end.
    
drop(P) ->
    modify(P, fun (_) -> none end).
    
null() ->
    fun (S) ->
        {ok, {none, S}}
    end.
    
listSepBy(P, SP) ->
    enlist([
        P,
        many(enlist([SP, P]))
    ]).

% pseudocode: inside(is $[, is "section", is $])
%        
inside(B, P) ->
    inside(B, P, B).
    
inside(B, P, A) ->
    one([
        drop(B),
        P,
        drop(A)
    ]).

% Whole string
%    
chunk(String) ->
    enlist(lists:map(fun char/1, String)).
    
is_letter() -> 
    {'or', [{'in_range', $A, $Z},
            {'in_range', $a, $z},
            {'equal_to', $_}]}.

is_number() ->
    {'in_range', $0, $9}.
    
spaces() -> many(drop(char($ ))).

many_tokens(P) -> many(word(P)).
    
many1_tokens(P) -> many1(word(P)).
    
word(Item) -> inside(spaces(), Item).

number() -> word(many1(that(is_number()))).

token(S) -> word(chunk(S)).

marked(Token, P) ->
    entuple([
        return(Token),
        P
    ]).
    
name() -> 
    word(
        enlist([
            that(is_letter()),
            many(that({'or', [is_letter(), is_number()]}))
        ])
    ).  

recuring(LP) ->
    fun(S) ->
        P = LP(nothing),
        P(S)
    end.

run(P, S) -> P(S).

%===============================================================================