LISP parsing in mercury

parser.m

:- module parser.

:- interface.

:- import_module char, list, value.

:- pred top_level_expression(lisp_value::out, list(char)::in, list(char)::out) is semidet.

:- implementation.

:- import_module bool, string, integer.

top_level_expression(Expr) -->
    optional_space,
    expression(Expr),
    optional_space.

:- pred expression(lisp_value::out, list(char)::in, list(char)::out) is semidet.
expression(Expression) -->
    (
        atom(Atom)     -> { Expression = Atom };
        string(String) -> { Expression = String };
        number(Number) -> { Expression = Number };
        quoted(Quoted) -> { Expression = Quoted };
        ['('], (
            dotted_list(DottedList) -> { Expression = DottedList };
            list(Expression)
        ), [')']
    ).

:- pred number(lisp_value::out, list(char)::in, list(char)::out) is semidet.
number(Number) --> number_raw(Digits),
                   {
                       string.from_char_list(Digits, String),
                       Integer = integer.from_string(String),
                       Number = lisp_number(Integer)
                   }.

:- pred number_raw(list(char)::out, list(char)::in, list(char)::out) is semidet.
number_raw(Chars) -->
    (
        % Appendo in modo ricorsivo finchè non trovo una non digit
        digit(ParsedDigit) -> { Chars = [ParsedDigit | Rest] }, number_raw(Rest);
                              { Chars = [] }
    ).

:- pred digit(char::out, list(char)::in, list(char)::out) is semidet.
digit(Digit) --> [Digit], { char.is_digit(Digit) }.

:- pred string(lisp_value::out, list(char)::in, list(char)::out) is semidet.
string(String) -->
    string_raw(RawString),
    {
        String = lisp_string(string.from_char_list(RawString))
    }.

:- pred string_raw(list(char)::out, list(char)::in, list(char)::out) is semidet.
string_raw(String) -->
    ['"'],
    string_content(String),
    ['"'].

:- pred string_content(list(char)::out, list(char)::in, list(char)::out) is semidet.
string_content(String) -->
    (
        not_quote(Char) -> { String = [Char | Rest ] }, string_content(Rest);
                           { String = [] }
    ).

:- pred not_quote(char::out, list(char)::in, list(char)::out) is semidet.
not_quote(Char) --> [Char], { Char \= '"' }.

:- pred atom(lisp_value::out, list(char)::in, list(char)::out) is semidet.
atom(Atom) -->
    raw_atom(RAtom),
    {
        SAtom = string.from_char_list(RAtom),
        (
            SAtom = "#t" -> Atom = lisp_bool(yes);
            SAtom = "#f" -> Atom = lisp_bool(no);
            Atom = lisp_atom(SAtom)
        )
    }.

:- pred raw_atom(list(char)::out, list(char)::in, list(char)::out) is semidet.
raw_atom(Name) -->
    ( letter(NameStartL) -> {NameStart = NameStartL }; 
      symbol(NameStart) ),
    atom_rest(NameRest),
    { Name = [NameStart | NameRest] }.

:- pred letter(char::out, list(char)::in, list(char)::out) is semidet.
letter(Letter) --> [Letter], { char.is_alpha(Letter) }.


:- pred symbol(char::out, list(char)::in, list(char)::out) is semidet.
symbol(Symbol) --> [Symbol], { string.contains_char("!$%&|*+-/:<=>?@^_~#", Symbol) }.

:- pred atom_rest(list(char)::out, list(char)::in, list(char)::out) is semidet.
atom_rest(Rest) -->
    (
        letter(Letter) -> atom_rest(LRest), { Rest = [Letter | LRest] };
        digit(Digit) -> atom_rest(DRest), { Rest = [Digit | DRest] };
        symbol(Symbol) -> atom_rest(SRest), { Rest = [Symbol | SRest] };
        { Rest = [] }
    ).

:- pred quoted(lisp_value::out, list(char)::in, list(char)::out) is semidet.
quoted(Quoted) -->
    ['\''],
    expression(Expression),
    {
        Quoted = lisp_list([lisp_atom("quote"), Expression])
    }.

:- pred dotted_list(lisp_value::out, list(char)::in, list(char)::out) is semidet.
dotted_list(DottedList) -->
    raw_dotted_list(List, Expression), { DottedList = lisp_dotted_list(List, Expression) }.

:- pred raw_dotted_list(list(lisp_value)::out, lisp_value::out, list(char)::in, list(char)::out) is semidet.
raw_dotted_list(List, Expression) -->
    raw_list(List), ['.'], space, expression(Expression).

:- pred list(lisp_value::out, list(char)::in, list(char)::out) is det.
list(List) --> raw_list(RList), { List = lisp_list(RList) }.

:- pred raw_list(list(lisp_value)::out, list(char)::in, list(char)::out) is det.
raw_list(List) -->
    (
        expression(Expression), space, raw_list(Rest) -> { List = [ Expression | Rest ] };
        expression(Expression)                        -> { List = [Expression] };
                                                         { List = [] }
    ).

:- pred space(list(char)::in, list(char)::out) is semidet.
space --> 
    (
        [' ']  -> optional_space;
        ['\t'], optional_space
    ).

:- pred optional_space(list(char)::in, list(char)::out) is det. 
optional_space -->
    ( 
        [' ']  -> optional_space; 
        ['\t'] -> optional_space;
        []
    )

show.m

:- module show.

:- interface.

:- import_module string, integer, list.

:- typeclass show(T) where [
    pred show(T::in, string::out) is det
].

:- instance show(string).
:- instance show(integer).

:- func show(T) = string <= show(T).

:- func unwords(list(string)) = string.
:- pred unwords(list(string)::in, string::out) is det.

:- implementation.

show(T) = String :- show(T, String).

:- instance show(string) where [
    (show(String, String))
].

:- instance show(integer) where [
    (show(Integer, integer.to_string(Integer)))
].

unwords(Stream, Out) :-
    (
        [X | Xs] = Stream ->  Out = X ++ " " ++ unwords(Xs);
        Out = ""
    ).

unwords(Stream) = Out :- unwords(Stream, Out).

value.m

:- module value.

:- interface.

:- import_module string, list, bool, integer, show.

:- instance show(lisp_value).

:- type lisp_value ---> lisp_atom(string)
                      ; lisp_list(list(lisp_value))
                      ; lisp_dotted_list(list(lisp_value), lisp_value)
                      ; lisp_number(integer)
                      ; lisp_string(string)
                      ; lisp_bool(bool.bool)
                      .

:- implementation.

:- instance show(lisp_value) where [
    pred(show/2) is show_lisp_value
].

:- pred show_lisp_value(lisp_value::in, string::out) is det.
show_lisp_value(lisp_atom(AtomName), Out) :-
    Out = show(AtomName).
show_lisp_value(lisp_list(Values), Out) :-
    Out = "(" ++ unwords(map(show, Values)) ++ ")".
show_lisp_value(lisp_dotted_list(Values, Last), Out) :-
    Out = "(" ++ unwords(map(show, Values)) ++ " . " ++ show(Last) ++ ")".
show_lisp_value(lisp_number(Num), Out) :-
    Out = show(Num).
show_lisp_value(lisp_string(String), Out) :-
    Out = "\"" ++ show(String) ++ "\"".
show_lisp_value(lisp_bool(bool.yes), Out) :-
    Out = "#t".
show_lisp_value(lisp_bool(bool.no), Out) :-
    Out = "#f".