gistfile1.prolog

:- module ml.
:- interface.
:- import_module io.
:- pred main(io::di, io::uo) is cc_multi.
:- implementation.
:- import_module bool, int, string, list, pair, assoc_list, lex, regex.

main(!IO) :-
    Lexer  = lex.init(lexemes, lex.read_from_stdin, ignore(space)),
    State0 = lex.start(Lexer, !.IO),
    tokenize(State0, State, [], Tokens),
    !:IO = lex.stop(State),
    print("Tokens:\n  ", Tokens, !IO),
    ( expr(Expr, Tokens, []) ->
        print("Syntax tree:\n  ", Expr, !IO),
        ( eval([], Expr, Value) -> 
            print("Value:\n  ", Value, !IO)
        ;
            io.write_string("Evaluation error\n", !IO)
        )
    ;
        io.write_string("Syntax error\n", !IO)
    ).

:- pred print(string::in, T::in, io::di, io::uo) is det.

print(Message, Result, !IO) :-
    io.write_string(Message, !IO),
    io.print(Result, !IO),
    io.nl(!IO),
    io.nl(!IO).

%-----------------------------------------------------------------------------%
%          Lexical analysis
%-----------------------------------------------------------------------------%

:- type token
    ---> num_token(int)
    ;    plus_token
    ;    minus_token
    ;    times_token
    ;    bool_token(bool)
    ;    lt_token
    ;    if_token
    ;    then_token
    ;    else_token
    ;    let_token
    ;    in_token
    ;    assign_token
    ;    ident_token(string)
    ;    fun_token
    ;    arrow_token
    ;    rec_token
    ;    l_paren
    ;    r_paren
    ;    space.

:- func lexemes = list(lexeme(token)).

lexemes = [
    ( nat        -> (func(Match) = num_token(string.det_to_int(Match))) ),
    ( "+"        -> return(plus_token) ),
    ( "-"        -> return(minus_token) ),
    ( "*"        -> return(times_token) ),
    ( "true"     -> return(bool_token(yes)) ),
    ( "false"    -> return(bool_token(no)) ),
    ( "<"        -> return(lt_token) ),
    ( "if"       -> return(if_token) ),
    ( "then"     -> return(then_token) ),
    ( "else"     -> return(else_token) ),
    ( "let"      -> return(let_token) ),
    ( "="        -> return(assign_token) ),
    ( "in"       -> return(in_token) ),
    ( "fun"      -> return(fun_token) ),
    ( "->"       -> return(arrow_token) ),
    ( "rec"      -> return(rec_token) ),
    ( "("        -> return(l_paren) ),
    ( ")"        -> return(r_paren) ),
    ( identifier -> (func(Match) = ident_token(Match)) ),
    ( whitespace -> return(space) )
].

:- pred tokenize(lexer_state(token, io)::di, lexer_state(token, io)::uo, list(token)::in, list(token)::out) is det.

tokenize(!LS, Xs, Ys) :-
    tokenize1(!LS, Xs, Ys1), Ys = list.reverse(Ys1).

:- pred tokenize1(lexer_state(token, io)::di, lexer_state(token, io)::uo, list(token)::in, list(token)::out) is det.

tokenize1(!LS, Xs, Ys) :-
    lex.read(Result, !LS),
    (
        Result = ok(Token),
        tokenize1(!LS, [Token | Xs], Ys)
    ;
        Result = eof,
        Ys = Xs
    ;
        Result = error(_, _),
        Ys = Xs
    ).

%-----------------------------------------------------------------------------%
%          Syntactic analysis
%-----------------------------------------------------------------------------%

:- type expr
    ---> num(int)
    ;    bool(bool)
    ;    plus(expr, expr)
    ;    minus(expr, expr)
    ;    times(expr, expr)
    ;    lt(expr, expr)
    ;    if(expr, expr, expr)
    ;    var(string)
    ;    let(string, expr, expr)
    ;    fun(string, expr)
    ;    app(expr, expr)
    ;    rec_fun(string, string, expr, expr).

:- pred expr(expr::out, list(token)::in, list(token)::out) is nondet.

expr(E) -->
    factor(E).

:- pred simple_expr(expr::out, list(token)::in, list(token)::out) is nondet.

simple_expr(E) -->
    (
        bool_expr(E)
    ;
        num_expr(E)
    ;
        if_expr(E)
    ;
        let_expr(E)
    ;
        var_expr(E)
    ;
        fun_expr(E)
    ;
        app_expr(E)
    ;
        rec_fun_expr(E)
    ;
        paren_expr(E)
    ).

:- pred factor(expr::out, list(token)::in, list(token)::out) is nondet.

factor(E) -->
    factor2(E0), infix_expr(E0, E).

:- pred infix_expr(expr::in, expr::out, list(token)::in, list(token)::out) is nondet.

infix_expr(E0, E) -->
    (
        ( [lt_token] -> factor2(E1), infix_expr(lt(E0, E1), E) )
    ;
        { E = E0 }
    ).

:- pred factor2(expr::out, list(token)::in, list(token)::out) is nondet.

factor2(E) -->
    factor3(E0), infix_expr2(E0, E).

:- pred infix_expr2(expr::in, expr::out, list(token)::in, list(token)::out) is nondet.

infix_expr2(E0, E) -->
    (
        ( [plus_token] -> factor3(E1), infix_expr2(plus(E0, E1), E) )
    ;
        ( [minus_token] -> factor3(E1), infix_expr2(minus(E0, E1), E) )
    ;
        { E = E0 }
    ).

:- pred factor3(expr::out, list(token)::in, list(token)::out) is nondet.

factor3(E) -->
    simple_expr(E0), infix_expr3(E0, E).

:- pred infix_expr3(expr::in, expr::out, list(token)::in, list(token)::out) is nondet.

infix_expr3(E0, E) -->
    (
        ( [times_token] -> simple_expr(E1), infix_expr3(times(E0, E1), E) )
    ;
        { E = E0 }
    ).

:- pred num_expr(expr::out, list(token)::in, list(token)::out) is semidet.

num_expr(E) -->
    [num_token(X)], { E = num(X) }.

:- pred bool_expr(expr::out, list(token)::in, list(token)::out) is semidet.

bool_expr(E) -->
    [bool_token(X)], { E = bool(X) }.

:- pred if_expr(expr::out, list(token)::in, list(token)::out) is nondet.

if_expr(E) -->
    [if_token], expr(X), [then_token], expr(Y), [else_token], expr(Z), { E = if(X, Y, Z) }.

:- pred var_expr(expr::out, list(token)::in, list(token)::out) is semidet.

var_expr(E) -->
    [ident_token(X)], { E = var(X) }.

:- pred let_expr(expr::out, list(token)::in, list(token)::out) is nondet.

let_expr(E) -->
    [let_token], [ident_token(X)], [assign_token], expr(Y), [in_token], expr(Z), { E = let(X, Y, Z) }.

:- pred fun_expr(expr::out, list(token)::in, list(token)::out) is nondet.

fun_expr(E) -->
    [fun_token], [ident_token(X)], [arrow_token], expr(Y), { E = fun(X, Y) }.

:- pred app_expr(expr::out, list(token)::in, list(token)::out) is nondet.

app_expr(E) -->
    var_expr(E1), expr(Y), { E = app(E1, Y) }.

:- pred rec_fun_expr(expr::out, list(token)::in, list(token)::out) is nondet.

rec_fun_expr(E) -->
    [let_token], [rec_token], [ident_token(X)], [assign_token],
    [fun_token], [ident_token(Y)], [arrow_token], expr(E1), [in_token], expr(E2),
    { E = rec_fun(X, Y, E1, E2) }.

:- pred paren_expr(expr::out, list(token)::in, list(token)::out) is nondet.

paren_expr(E) -->
    [l_paren], expr(E), [r_paren].

%-----------------------------------------------------------------------------%
%          Evaluation
%-----------------------------------------------------------------------------%

:- type env == assoc_list(string, value).

:- type value
    ---> num_value(int)
    ;    bool_value(bool)
    ;    fun_value(env, string, expr)
    ;    rec_fun_value(env, string, string, expr)
    ;    error.

:- pred eval(env::in, expr::in, value::out) is nondet.

eval(Env, Expr, Value) :-
    (
        Expr = num(X),
        Value = num_value(X)
    ;
        Expr = bool(X),
        Value = bool_value(X)
    ;
        Expr = plus(X, Y), eval(Env, X, V1), eval(Env, Y, V2),
        V1 = num_value(N1), V2 = num_value(N2),
        Value = num_value(N1 + N2)
    ;
        Expr = minus(X, Y), eval(Env, X, V1), eval(Env, Y, V2),
        V1 = num_value(N1), V2 = num_value(N2),
        Value = num_value(N1 - N2)
    ;
        Expr = times(X, Y), eval(Env, X, V1), eval(Env, Y, V2),
        V1 = num_value(N1), V2 = num_value(N2),
        Value = num_value(N1 * N2)
    ;
        Expr = lt(X, Y), eval(Env, X, V1), eval(Env, Y, V2),
        V1 = num_value(N1), V2 = num_value(N2),
        Value = bool_value(pred_to_bool(N1 < N2))
    ;
        Expr = if(X, Y, Z), eval(Env, X, V1),
          (
              V1 = bool_value(yes), eval(Env, Y, Value)
          ;
              V1 = bool_value(no), eval(Env, Z, Value)
          )
    ;
        Expr = var(X), assoc_list.search(Env, X, Value)
    ;
        Expr = let(X, Y, Z), eval(Env, Y, V), eval([pair(X, V) | Env], Z, Value)
    ;
        Expr = fun(X, Y),
        Value = fun_value(Env, X, Y)
    ;
        Expr = app(X, Y), eval(Env, X, V1), eval(Env, Y, V2),
        (
            fun_value(E, F, B) = V1,
            eval([pair(F, V2)|E], B, Value)
        ;
            rec_fun_value(Env1, F1, F2, B) = V1,
            eval([pair(F1, V1)|[pair(F2, V2)|Env1]], B, Value)
        )
    ;
        Expr = rec_fun(X, Y, E1, E2), eval([pair(X, rec_fun_value(Env, X, Y, E1)) | Env], E2, Value)
    ).