#!/usr/bin/perl -w
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License, or (at
#  your option) any later version.
#
#  This program is distributed in the hope that it will be useful, but
#  WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
#  General Public License for more details.
#
#  You should have received a copy of the GNU General Public License
#  along with this program; if not, write to the Free Software
#  Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston,
#  MA 02110-1301, USA.
#
#  Copyright © 2007 Pierre Habouzit

use strict;

my %types;
my %pkgs;

#{{{ stream functions

sub stream_open($) {
    my $name = shift;
    open FILE, $name;
    return (file => $name, line => 0, f => \*FILE);
}

sub stream_close($) {
    my $stream = shift;
    close $stream->{f};
}

sub stream_getline($) {
    my $stream = shift;
    my $file   = $stream->{f};
    while (<$file>) {
        ${$stream}{line}++;
        return $_;
    }
    return;
}

#}}}

#{{{ file:line functions

sub fatal($$) {
    my ($stream, $msg) = @_;
    printf STDERR "%s:%d: %s\n", $stream->{file}, $stream->{line}, $msg;
    exit 1;
}

sub get_pos($$) {
    my ($h,$k) = @_;
    return $h->{$k}{file}.':'.$h->{$k}{line};
}

sub put_line($$) {
    my ($src,$inc) = @_;
    printf "#line %d \"%s\"\n", $src->{line} + $inc, $src->{file};
}

#}}}

#{{{ parsers

sub parse_type($$) {
    my ($src, $type) = @_;
    my %t = (
        name => $type,
        file => $src->{file},
        line => $src->{line},
    );

    if (defined $types{$type}) {
        my $pos = get_pos(\%types, $type);
        fatal($src, "already defined type: `$type' at $pos");
    }

    while (stream_getline($src)) {
        last if (/^\s*\}\s*;\s*/);
        if (/^\s*\.(push|kind|ctype|dtor|ctor|check)\s*=\s*(.*?)\s*;\s*$/) {
            $t{$1} = $2;
            if ($1 eq "kind") {
                if ($2 =~ /^'([bis])'$/) {
                    $t{kind} = $1;
                } else {
                    fatal($src, "error: .kind should be [ibs] got $2)");
                }
            }
        } elsif (!/^\s*$/) {
            fatal($src, "syntax error: unknown type directive");
        }
    }

    for ('kind', 'ctype') {
        fatal($src, "incomplete type $type: missing .$_") unless defined $t{$_};
    }
    if ($t{kind} eq 's') {
        for ('dtor', 'ctor') {
            fatal($src, "incomplete type $type: missing .$_") unless defined $t{$_};
        }
    }
    unless (defined $t{check}) {
        if ($t{kind} eq 'b') {
            $t{check} = '(luaL_checkint($L, $$) == 0)';
        }

        if ($t{kind} eq 'i') {
            $t{check} = 'luaL_checkint($L, $$)';
        }

        if ($t{kind} eq 's') {
            $t{check} = 'luaL_checkstring($L, $$)';
        }
    }

    $t{ctypefmt} .= ' %s' unless (($t{ctypefmt} = $t{ctype}) =~ s/:/ \%s :/);
    $t{ctype} =~ s/:.*//;

    return $types{$type} = \%t;
}

sub parse_package($$) {
    my ($src, $pkg) = @_;
    my %p = (
        name => $pkg,
        file => $src->{file},
        line => $src->{line},
    );

    if (defined $pkgs{$pkg}) {
        my $pos = get_pos(\%pkgs, $pkg);
        fatal($src, "already defined package: `$pkg' at $pos");
    }

    while (stream_getline($src)) {
        if (/^\s*\}\s*(\w+)\s*;\s*$/) {
            $p{cname} = $1;
            last;
        }

        if (/^\s*(.*?)\s*=\s*(.*?)\s*;\s*$/) {
            my ($lhs, $rhs) = ($1, $2);
            my %m = ( file => $src->{file}, line => $src->{line} );

            if ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w+)$/) {
                $m{type} = $1;
                $m{name} = $2;
                $m{init} = $rhs;
                push @{$p{props}}, $2;
            } elsif ($lhs =~ /^((?:const\s+)?\w+?)\s*(\w*)\((.*)\)$/) {
                $m{type}  = $1;
                $m{name}  = $2;
                $m{proto} = $3;
                $m{cfun}  = $rhs;
                push @{$p{meths}}, $2;
            } else {
                fatal($src, "syntax error");
            }

            if (defined $p{members}{$m{name}}) {
                my $pos = get_pos($p{members}{$m{name}}, 0);
                fatal($src, "already defined package member: `$m{name}' at $pos");
            }

            $p{members}{$m{name}} = \%m;
            next;
        }

        if (!/^\s*$/) {
            fatal($src, "syntax error");
        }
    }

    return $pkgs{$pkg} = \%p;
}

sub find_type($$) {
    my ($ref, $typ) = @_;

    if ($typ =~ /^const\s+(\w*)$/) {
        fatal($ref, "undefined type `$1'") unless defined $types{$1};
        return (const => 1, type => $types{$1});
    }

    fatal($ref, "undefined type `$typ'") unless defined $types{$typ};
    return (const => 0, type => $types{$typ});
}

#}}}

#{{{ dump_fun

sub dump_fun($$) {
    my ($pkg, $f) = @_;
    my %t    = find_type($f, $f->{type});
    my $call = $f->{cfun};
    $call =~ s/\$/var/;

    print "static int luaM_${pkg}_$f->{name}(lua_State *L) {\n";

    if ($f->{proto} ne "void") {
        my $i = 1;
        for my $tmp (split /,/,$f->{proto}) {
            s/^\s+//;
            s/\s+$//;

            my %pt = find_type($f, $tmp);
            my $check = $pt{type}->{check};
            $check =~ s/\$L/L/;
            $check =~ s/\$\$/\%d/;

            put_line($pt{type}, 0);
            printf "    $pt{type}->{ctype} var$i = $check\n", $i++;
        }
    }

    if (defined $t{type}->{push}) {
        $call =~ s/\$\$/$t{type}->{push}/;
    }

    if ($t{type}->{kind} eq 'b') {
        put_line($f, 0);
        print "    lua_pushboolean(L, $call);\n";
    }

    if ($t{type}->{kind} eq 'i') {
        put_line($f, 0);
        print "    lua_pushint(L, $call);\n";
    }

    if ($t{type}->{kind} eq 's') {
        if ($t{const}) {
            put_line($f, 0);
            print "    lua_pushstring(L, $call);\n";
        } else {
            print "    {\n";
            put_line($f, 0);
            print "        char *s = $call;\n";
            print "        lua_pushstring(L, s);\n";
            print "        p_delete(&s);\n";
            print "    }\n";
        }
    }

    printf "    return %d;\n", ($f->{type} ne "void");
    print "}\n";
}

#}}}

#{{{ dump_struct

sub dump_struct_full($) {
    my ($pkg) = @_;

    put_line($pkg, 0);
    print "struct luaM_$pkg->{name}_t $pkg->{cname} = {\n";

    foreach (@{$pkg->{props}}) {
        my $p = $pkg->{members}{$_};
        my %t = find_type($p, $p->{type});

        if ($t{const}) {
            put_line($p, 0);
            print "    $p->{init},\n";
        } else {
            print "    0,\n"    if ($t{type}->{kind} eq 'b');
            print "    0,\n"    if ($t{type}->{kind} eq 'i');
            print "    NULL,\n" if ($t{type}->{kind} eq 's');
        }
    }

    print <<EOF;
};

static void $pkg->{cname}_init(void)
{
EOF

    foreach (@{$pkg->{props}}) {
        my $p   = $pkg->{members}{$_};
        my %t   = find_type($p, $p->{type});
        my $var = $pkg->{cname}.".".$p->{name};

        next if $t{const};

        put_line($p, 0);
        if ($t{type}->{dtor}) {
            my $dtor = $t{type}->{dtor};
            $dtor =~ s/\$L/L/;
            $dtor =~ s/\$\$/\&$var/;
            print "    $dtor;\n";
        }
        print "    $var = $p->{init};\n"
    }
    print "};\n";
};

sub dump_struct_short($) {
    my ($pkg) = @_;

    print "struct luaM_$pkg->{name}_t {\n";
    foreach (@{$pkg->{props}}) {
        my $p = $pkg->{members}{$_};
        my %t = find_type($p, $p->{type});
        if ($t{const}) {
            printf "    const $t{type}->{ctypefmt};\n", $p->{name};
        } else {
            printf "    $t{type}->{ctypefmt};\n", $p->{name};
        }
    }
    put_line($pkg, 0);
    print <<EOF;
};

extern struct luaM_$pkg->{name}_t $pkg->{cname};
EOF
}

sub dump_struct_static($) {
    my ($pkg) = @_;

    print "static struct {\n";
    foreach (@{$pkg->{props}}) {
        my $p = $pkg->{members}{$_};
        my %t = find_type($p, $p->{type});
        if ($t{const}) {
            printf "    const $t{type}->{ctypefmt};\n", $p->{name};
        } else {
            printf "    $t{type}->{ctypefmt};\n", $p->{name};
        }
    }
    put_line($pkg, 0);
    print "} $pkg->{cname} = {\n";

    foreach (@{$pkg->{props}}) {
        my $p = $pkg->{members}{$_};
        my %t = find_type($p, $p->{type});

        if ($t{const}) {
            put_line($p, 0);
            print "    $p->{init},\n";
        } else {
            print "    0,\n"    if ($t{type}->{kind} eq 'b');
            print "    0,\n"    if ($t{type}->{kind} eq 'i');
            print "    NULL,\n" if ($t{type}->{kind} eq 's');
        }
    }

    print <<EOF;
};

static void $pkg->{cname}_init(void)
{
EOF

    foreach (@{$pkg->{props}}) {
        my $p   = $pkg->{members}{$_};
        my %t   = find_type($p, $p->{type});
        my $var = $pkg->{cname}.".".$p->{name};

        next if $t{const};

        put_line($p, 0);
        if ($t{type}->{dtor}) {
            my $dtor = $t{type}->{dtor};
            $dtor =~ s/\$L/L/;
            $dtor =~ s/\$\$/\&$var/;
            print "    $dtor;\n";
        }
        print "    $var = $p->{init};\n"
    }
    print "};\n";
};

#}}}

#{{{ dump package

sub dump_package_full($$) {
    my ($pkg, $static) = @_;

    if ($static) {
        dump_struct_static($pkg);
    } else {
        dump_struct_full($pkg);
    }
    map { print "\n"; dump_fun($pkg->{name}, $pkg->{members}{$_}); } @{$pkg->{meths}};
    print <<EOF;

static const luaL_reg luaM_$pkg->{name}_methods[] = {
EOF
    map { print "    { \"$_\", luaM_$pkg->{name}_$_ },\n"; } @{$pkg->{meths}};
    print <<EOF;
    { NULL, NULL }
};

static int luaM_$pkg->{name}_index(lua_State *L)
{
    const char *idx = luaL_checkstring(L, 2);

    switch (mlua_which_token(idx, -1)) {
EOF

    foreach (@{$pkg->{props}}) {
        my $p = $pkg->{members}{$_};
        my %t = find_type($p, $p->{type});
        my $call = $pkg->{cname}.".".$p->{name};

        my $tok = $p->{name};
        $tok =~ tr/a-z/A-Z/;

        if ($t{type}->{kind} eq 'b') {
            $call = "lua_pushboolean(L, $call)";
        }

        if ($t{type}->{kind} eq 'i') {
            $call = "lua_pushinteger(L, $call)";
        }

        if ($t{type}->{kind} eq 's') {
            $call = "lua_pushstring(L, $call)";
        }

        if (defined $t{type}->{push}) {
            $call =~ s/\$\$/$t{type}->{push}/;
        }

        put_line($p, 0);
        print  "      case LTK_$tok:\n";
        printf "        $call;\n";
        print  "        return 1;\n";
    }

print <<EOF;
      default:
        lua_rawget(L, lua_upvalueindex(2));       /* try methods       */
        return 1;
    }
}

static int luaM_$pkg->{name}_newindex(lua_State *L)
{
    const char *idx = luaL_checkstring(L, 2);

    switch (mlua_which_token(idx, -1)) {
EOF

    foreach (@{$pkg->{props}}) {
        my $p = $pkg->{members}{$_};
        my %t = find_type($p, $p->{type});

        next if ($t{const});

        my $tok = $p->{name};
        my $var = $pkg->{cname}.".".$p->{name};
        my $check = $t{type}->{check};
        $tok   =~ tr/a-z/A-Z/;
        $check =~ s/\$L/L/;
        $check =~ s/\$\$/3/;

        put_line($p, 0);
        print  "      case LTK_$tok: \n";
        if ($t{type}->{dtor}) {
            my $dtor = $t{type}->{dtor};
            $dtor =~ s/\$L/L/;
            $dtor =~ s/\$\$/\&$var/;
            print "        $dtor;\n";
        }
        if ($t{type}->{ctor}) {
            my $ctor = $t{type}->{ctor};
            $ctor =~ s/\$L/L/;
            $ctor =~ s/\$\$/$check/;
            $check = $ctor;
        }
        print "        $var = $check;\n";
        print "        return 1;\n";
    }

print <<EOF;
      default:
        return 1;
    }
}

int luaopen_$pkg->{name}(lua_State *L)
{
    int mt, methods;

    $pkg->{cname}_init();

    /* create methods table, add it the the table of globals */
    luaL_openlib(L, "$pkg->{name}", luaM_$pkg->{name}_methods, 0);
    methods = lua_gettop(L);

    /* create metatable for $pkg->{name}, add it to the registry */
    luaL_newmetatable(L, "$pkg->{name}");
    mt = lua_gettop(L);

    lua_pushliteral(L, "__index");
    lua_pushvalue(L, mt);                       /* upvalue 1         */
    lua_pushvalue(L, methods);                  /* upvalue 2         */
    lua_pushcclosure(L, &luaM_$pkg->{name}_index, 2);
    lua_rawset(L, mt);                          /* set mt.__index    */

    lua_pushliteral(L, "__newindex");
    lua_newtable(L);                            /* for new members   */
    lua_pushcclosure(L, &luaM_$pkg->{name}_newindex, 1);
    lua_rawset(L, mt);                          /* set mt.__newindex */

    lua_pushliteral(L, "__metatable");
    lua_pushvalue(L, methods);                  /* dup methods table */
    lua_rawset(L, mt);                          /* hide metatable    */

    lua_setmetatable(L, methods);

    lua_pop(L, 1);                              /* drop mt           */
    return 1;                                   /* return methods    */
}

EOF
}

sub dump_package_short($) {
    my $pkg = shift;
    my $upp = $pkg->{name};
    $upp =~ tr/a-z/A-Z/;

    print <<EOF;
#ifndef MUTT_LUA_${upp}_H
#define MUTT_LUA_${upp}_H

EOF
    dump_struct_short($pkg);
    print <<EOF

int luaopen_$pkg->{name}(lua_State *L);

#endif /* MUTT_LUA_${upp}_H */
EOF
}

#}}}

sub do_c($) {
    my %src = stream_open(shift);
    my $resync = 1;

    while (stream_getline(\%src)) {
        if (/^\s*\@type\s+([a-zA-Z]\w*)\s*=\s*{\s*$/) {
            parse_type(\%src, $1);
            $resync = 1;
        } elsif (/^\s*static\s+\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
            dump_package_full(parse_package(\%src, $1), 1);
            $resync = 1;
        } elsif (/^\s*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
            dump_package_full(parse_package(\%src, $1), 0);
            $resync = 1;
        } elsif (/^\s*(\@\w*)/) {
            fatal(\%src, "syntax error: unknown directive `$1'");
        } else {
            next if ($resync && /^\s+$/);
            if ($resync) {
                put_line(\%src, 0);
                $resync = 0;
            }
            print;
        }
    }

    stream_close(\%src);
}

sub do_h($) {
    my %src = stream_open(shift);
    my $resync = 1;

    while (stream_getline(\%src)) {
        if (/^\s*\@type\s+([a-zA-Z]\w*)\s*=\s*{\s*$/) {
            parse_type(\%src, $1);
        } elsif (/^\s*\@package\s+([a-zA-Z]\w*)\s+{\s*$/) {
            dump_package_short(parse_package(\%src, $1));
        } elsif (/^\s*(\@\w*)/) {
            fatal(\%src, "syntax error: unknown directive `$1'");
        }
    }

    stream_close(\%src);
}

if ($#ARGV < 1 || ($ARGV[0] ne "-h" && $ARGV[0] ne "-c")) {
    print <<EOF;
usage: mluapkg (-h | -c) file.pkg
EOF
    exit 1;
}

print <<EOF;
/*****     THIS FILE IS AUTOGENERATED DO NOT MODIFY DIRECTLY !    *****/
EOF

map { do_h($ARGV[$_]); } (1 .. $#ARGV) if ($ARGV[0] eq '-h');
map { do_c($ARGV[$_]); } (1 .. $#ARGV) if ($ARGV[0] eq '-c');
