(*
 *  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
 *)
{
  open Printf
  module L = Lexing
  module H = Hashtbl
  module B = Buffer

  type 'a anchor   = ('a * string * int)
  let t1 (a, _, _) = a

  let die lpos fpos s =
    output_string stderr (sprintf "%s:%d: %s\n" fpos lpos s);
    exit 1

  let put_line ob = fprintf ob "#line %d \"%s\"\n"

  let isspace = function |' '|'\t' -> true | _ -> false

  let output_endline ob s = output_string ob s; output_char ob '\n'

  let strip s =
    let l = ref 0 and r = ref (String.length s) in
    while (isspace s.[!l]     && !l < !r) do incr l done;
    while (isspace s.[!r - 1] && !l < !r) do decr r done;
    String.sub s !l (!r - !l)

(* @types related {{{ *)

  type typedef =
    { lpos: int; fpos: string;
      ctype: string anchor;
      check: string anchor;
      push : string anchor;
      ctor : string anchor option;
      dtor : string anchor option;
    }
  let typedef0 =
    { lpos  = 0; fpos = "";
      ctype = "", "", 0;
      check = "", "", 0;
      push  = "", "", 0;
      ctor  = None;
      dtor = None
    }
  let types = H.create 1031


  let (@:=) id  t =
    List.iter (function ((s,_,_), x) -> if String.length s == 0 then
      die t.lpos t.fpos (sprintf "type `%s' has no `%s' set" id x))
    [(t.ctype, "ctype"); (t.check, "check"); (t.push, "push")];
    H.add types id t

(* }}} *)
(* @packages related {{{ *)

  type typinst = bool * typedef

  type members =
    { typ: typinst; mname: string;
      init: string anchor; onchange: string anchor option; }
  let member0 =
    { typ   = false, typedef0;
      mname = "";
      init = "", "", 0;
      onchange = None;
    }

  type methods =
    { rettype: typinst list; args: (typinst * string) list;
      fname: string; body: string }

  type package =
    { line: int; file: string; name: string;
      members: members anchor list;
      methods: methods anchor list;
      static: bool;
    }

  let newpkg lpos fpos name static =
    { static = static; line = lpos; file = fpos; name = name; members = []; methods = []; }

  let type_find lpos fpos t =
    try Hashtbl.find types t
    with Not_found -> die lpos fpos (sprintf "Unknown type `%s'" t)

  let parse_rettype lpos fpos s =
    let aux t =
      match Str.split (Str.regexp "[ \t]+") t with
      | ["const"; t] -> (true,  type_find lpos fpos t)
      | [t]          -> (false, type_find lpos fpos t)
      | _ -> assert false
    in
    match strip s with
    | "void" -> []
    | s      -> List.map aux (Str.split (Str.regexp "[ \t]*,[ \t]*") s)

  let parse_args lpos fpos s =
    let aux t =
      match Str.split (Str.regexp "[ \t]+") t with
      | ["const"; t; n] -> ((true,  type_find lpos fpos t), n)
      | [t; n]          -> ((false, type_find lpos fpos t), n)
      | _ -> assert false
    in
    match strip s with
    | "void" -> []
    | s      -> List.map aux (Str.split (Str.regexp "[ \t]*,[ \t]*") s)

(* }}} *)
(* parsing helpers {{{ *)

  type stanza = Buf of string anchor | Pkg of package

  let nextl lexbuf =
    let pos = lexbuf.L.lex_curr_p in
    lexbuf.L.lex_curr_p <-
      { pos with
        L.pos_lnum = pos.L.pos_lnum + 1;
        L.pos_bol  = pos.L.pos_cnum; };
    lexbuf
  ;;

  let lnum lexbuf = lexbuf.L.lex_curr_p.L.pos_lnum

  let (@.)  buf s = B.add_string buf s; buf
  let (@<)  buf c = B.add_char   buf c; buf

  let getchunk lpos fpos buf lexbuf =
    let res = B.contents buf in
    B.clear buf;
    Buf(res, fpos, lpos)

  let startchunk f fpos lexbuf =
    f (lnum lexbuf) fpos (B.create 4096) lexbuf

  let newchunk f lpos fpos buf lexbuf =
    let res = getchunk lpos fpos buf lexbuf in
    res::(f (lnum lexbuf, fpos) buf lexbuf)

  let find_import relpath file =
    if Filename.is_relative file then
      match Filename.dirname relpath with
      | "." -> file
      | s   -> Filename.concat s file
    else
      file

(* }}} *)
}

(* regex aliases {{{ *)

let to_eol = [^'\n']* '\n'
let ident  = ['a'-'z''A'-'Z''_']['a'-'z''A'-'Z''_''0'-'9']*
let sp     = [' ''\t']

let typdecl = sp* ("const" sp+)? ident sp*

(* }}} *)
(* entry point {{{ *)

rule cLine lpos fpos buf = parse
| sp* "@type" sp+ (ident as id) sp* (':' sp* (ident as id0) sp*)? '{'
                    {
                      let line = lnum lexbuf in
                      let t0 = match id0 with
                      | None     -> typedef0
                      | Some id0 ->
                          try H.find types id0
                          with Not_found ->
                            die line fpos (sprintf "Uknown type `%s'" id0)
                      in try
                        let t = H.find types id in
                        die line fpos
                          (sprintf "type `%s' already defined at %s:%d"
                            id t.fpos t.lpos)
                      with Not_found ->
                        (getchunk lpos fpos buf lexbuf) :: (
                          ext_type id {t0 with lpos = line; fpos = fpos}
                            lexbuf
                        )
                    }
| sp* "@import" sp+ '"' ([^'"''\n']* as file) '"' sp* '\n'
                    {
                      let file = find_import fpos file in
                      let _ = startchunk cLine file
                                (L.from_channel (open_in file)) in
                      cLine lpos fpos (buf @< '\n') (nextl lexbuf)
                    }
| sp* ("@package"|"@static_package" as kw) sp+ (ident as pkg) sp* '{'
                    {
                      let a = getchunk lpos fpos buf lexbuf in
                      let line = lnum lexbuf in
                      a::(ext_pkg (newpkg line fpos pkg
                                    (kw = "@static_package")) lexbuf)
                    }
| sp* '@'           { die (lnum lexbuf) fpos "Syntax error" }
| sp* '#' as s      { let buf = cPP (buf @. s) lexbuf in
                      cLine lpos fpos buf lexbuf }
| ""                { let buf = cCode buf lexbuf in
                      cLine lpos fpos buf lexbuf }
| eof               { [getchunk lpos fpos buf lexbuf] }

(* }}} *)
(* cCode block parser {{{ *)

and cCode buf = parse
| '\n'    as c      { let _ = nextl lexbuf in buf @< c }
| '"'     as c      { let buf = cString (buf @< c) lexbuf in
                      cCode buf lexbuf }
| "/*"    as s      { let buf = cComment (buf @. s) lexbuf in
                      cCode buf lexbuf }
| "//" to_eol as s  { cCode (buf @. s) (nextl lexbuf) }
| "'\"'"  as s      { cCode (buf @. s) lexbuf }
| _       as c      { cCode (buf @< c) lexbuf }

(* }}} *)
(* helper rules: comment, string, cPP {{{ *)

and cComment buf = parse
| "*/"    as s { buf @. s }
| '\n'    as c { cComment (buf @< c) (nextl lexbuf) }
| _       as c { cComment (buf @< c) lexbuf }

and cString buf = parse
| '"'     as c { buf @< c }
| "\\\""  as s { cString (buf @. s) lexbuf }
| "\\\n"  as s { cString (buf @. s) (nextl lexbuf) }
| [^'\n'] as c { cString (buf @< c) lexbuf }

and cPP buf = parse
| [^'\n']* "\\\n" as s { cPP (buf @. s) (nextl lexbuf) }
| to_eol          as s { let _ = nextl lexbuf in buf @. s }

(* }}} *)
(* parse @type {{{ *)

and ext_type id typ = parse
| sp+
| "//" to_eol       { ext_type id typ lexbuf }
| '\n'              { ext_type id typ (nextl lexbuf) }
| "/*"              { let _ = cComment (B.create 1024) lexbuf in
                      ext_type id typ lexbuf }
| '.' (ident as member) sp* '=' sp* ([^';''\n']+ as s) ';'
                    {
                      ext_type id (
                        let do_anch s = s, typ.fpos, lnum lexbuf in
                        match member with
                        | "ctype" -> {typ with ctype = do_anch s}
                        | "check" -> {typ with check = do_anch s}
                        | "push"  -> {typ with push  = do_anch s}
                        | "ctor"  -> {typ with ctor  = Some (do_anch s)}
                        | "dtor"  -> {typ with dtor  = Some (do_anch s)}
                        | _       ->
                            die (lnum lexbuf) typ.fpos
                              (sprintf "Unknown directive `%s'" member)
                      ) lexbuf
                    }
| '}' sp* ';' (sp* '\n' as s)?
                    { id @:= typ; startchunk cLine typ.fpos
                      (if s = None then lexbuf else nextl lexbuf) }
| ""                { die (lnum lexbuf) typ.fpos "Syntax error" }

(* }}} *)
(* parse @package {{{ *)

and ext_pkg pkg = parse
| sp+
| "//" to_eol       { ext_pkg pkg lexbuf }
| '\n'              { ext_pkg pkg (nextl lexbuf) }
| "/*"              { let _ = cComment (B.create 1024) lexbuf in
                      ext_pkg pkg lexbuf }
| ("const" sp+ as const)? (ident as typ) sp+
  (ident as member) sp* '=' sp* '{'
                    {
                      let m = {member0 with mname = member;
                               typ = const != None, type_find (lnum lexbuf)
                               pkg.file typ; } in
                      let m = ext_member m pkg.file lexbuf in
                      ext_pkg {pkg with members = (m, pkg.file, lnum lexbuf)::pkg.members} lexbuf
                    }
| ("const" sp+ as const)? (ident as typ) sp+
  (ident as member) sp* '=' sp* ([^';''\n']* as init)';'
                    {
                      let m = { typ   = const != None,
                                        type_find (lnum lexbuf) pkg.file typ;
                                mname = member;
                                init  = init, pkg.file, lnum lexbuf;
                                onchange = None; }, pkg.file, lnum lexbuf in
                      ext_pkg {pkg with members = m::pkg.members} lexbuf
                    }
| '(' ((typdecl ',')* typdecl as ret) ')' sp*
   (ident as fname)
   '('((typdecl ident sp* ',')* typdecl ident sp* as args)')' sp*
| (typdecl as ret) (ident as fname)
   '('((typdecl ident sp* ',')* typdecl ident sp* as args)')' sp*
                    {
                      let rettype = parse_rettype (lnum lexbuf) pkg.file ret in
                      let args    = parse_args    (lnum lexbuf) pkg.file args in
                      let f, l    = pkg.file, lnum lexbuf in
                      let body    = ext_body pkg (B.create 1024) lexbuf in
                      let m       = { rettype = rettype;
                                      args = args;
                                      fname = fname;
                                      body = body }, f, l in
                      ext_pkg {pkg with methods = m::pkg.methods} lexbuf
                    }
| '}' sp* ';' (sp* '\n' as s)?
                    { Pkg({pkg with members = List.rev(pkg.members)}) :: (
                        startchunk cLine pkg.file
                        (if s = None then lexbuf else nextl lexbuf)
                      )
                    }
| ""                { die (lnum lexbuf) pkg.file "Syntax error" }

and ext_body pkg buf = parse
| sp+         as s
| "//" to_eol as s  { ext_body pkg (buf @. s) lexbuf }
| '\n'        as c  { ext_body pkg (buf @< c) lexbuf }
| "/*"              { let buf = cComment (buf @. "/*") lexbuf in
                      ext_body pkg buf lexbuf }
| ';'               { B.contents buf }
| '{'         as c  { let buf = ext_bodycode (buf @< c) lexbuf in
                      ext_body pkg buf lexbuf }
| ""                { die (lnum lexbuf) pkg.file "Syntax error" }

and ext_bodycode buf = parse
| '\n'    as c      { ext_bodycode (buf @< c) (nextl lexbuf) }
| '"'     as c      { let buf = cString (buf @< c) lexbuf in
                      ext_bodycode buf lexbuf }
| "/*"    as s      { let buf = cComment (buf @. s) lexbuf in
                      ext_bodycode buf lexbuf }
| "//" to_eol as s  { ext_bodycode (buf @. s) (nextl lexbuf) }
| "'\"'"  as s      { ext_bodycode (buf @. s) lexbuf }
| '{'     as c      { let buf = ext_bodycode (buf @< c) lexbuf in ext_bodycode buf lexbuf }
| '}'     as c      { buf @< c }
| _       as c      { ext_bodycode (buf @< c) lexbuf }

(* }}} *)
(* parse extended member {{{ *)

and ext_member m f = parse
| sp+
| "//" to_eol       { ext_member m f lexbuf }
| '\n'              { ext_member m f (nextl lexbuf) }
| "/*"              { let _ = cComment (B.create 1024) lexbuf in
                      ext_member m f lexbuf }
| '.' (ident as member) sp* '=' sp* ([^';''\n']+ as s) ';'
                    {
                      ext_member (
                        let do_anch s = s, f, lnum lexbuf in
                        match member with
                        | "init"     -> {m with init = do_anch s}
                        | "onchange" -> {m with onchange = Some(do_anch s)}
                        | _       ->
                            die (lnum lexbuf) f
                              (sprintf "Unknown directive `%s'" member)
                      ) f lexbuf
                    }
| '}' sp* ';'       { m }
| ""                { die (lnum lexbuf) f "Syntax error" }

(* }}} *)

{
(* templating functions {{{ *)

  let upper = String.uppercase
  let tplize tpl v =
    Str.global_replace (Str.regexp_string "$L") "L" (
      Str.global_replace (Str.regexp_string "$$") v tpl
    )

  let dump_struct_type ob begwith pkg endwith =
    fprintf ob "%sstruct luaM_%s_t {\n" begwith pkg.name;
    List.iter (function (m, f, l) ->
      put_line ob l f;
      let ctype = t1 (snd m.typ).ctype in
      output_string ob "    ";
      if fst m.typ then output_string ob "const ";
      let i = try String.index ctype ':' with Not_found -> String.length ctype in
      fprintf ob "%s %s%s;\n" (Str.string_before ctype i)
        m.mname (Str.string_after ctype i)
    ) pkg.members;
    output_endline ob ("}" ^ endwith)

  let do_h ob =
    let do_h_aux = function
      | Buf _ -> ()
      | Pkg pkg ->
          fprintf ob "\n#ifndef MUTT_LUA_%s_H\n" (upper pkg.name);
          fprintf ob "#define MUTT_LUA_%s_H\n\n" (upper pkg.name);
          if not pkg.static then (
            dump_struct_type ob "" pkg ";";
            fprintf ob "extern struct luaM_%s_t %s;\n" pkg.name pkg.name;
          );
          fprintf ob "\nint luaopen_%s(lua_State *L);\n\n" pkg.name;
          fprintf ob "#endif /* MUTT_LUA_%s_H */\n" (upper pkg.name);
    in List.iter do_h_aux

  let do_func ob pkg (fn, f, l) = 
    (* return inline function *)
    fprintf ob "\nstatic int luaM_ret_%s_%s(lua_State *L" pkg.name fn.fname;
    let retlen = List.fold_left (fun i t ->
      let i = i + 1 in
      match t with
      | true, typ -> fprintf ob ", const %s luaM_x%d" (t1 typ.ctype) i; i
      | false, typ -> fprintf ob ", %s luaM_x%d" (t1 typ.ctype) i; i
      ) 0 fn.rettype in
    fprintf ob ")\n{\n";
    ignore (List.fold_left (fun i (const, typ) ->
      let i = i + 1 in
      let (p, f, l) = typ.push in
      put_line ob l f;
      fprintf ob "    %s;\n" (tplize p (sprintf "luaM_x%d" i));
      if not const then (
        match typ.dtor with
        | None             -> ()
        | Some(dtor, f, l) ->
            put_line ob l f;
            fprintf ob "    %s;\n" (tplize dtor (sprintf "&luaM_x%d" i))
      ); i
    ) 0 fn.rettype) ;
    fprintf ob "    return %d;\n}\n" retlen;

    (* main function *)
    fprintf ob "\nstatic int luaM_%s_%s(lua_State *L)\n{\n" pkg.name fn.fname;
    ignore (List.fold_left (fun i ((const, typ), name) ->
      let i = i + 1 in
      let ctype = t1 typ.ctype in
      if const then (
        let (c, f, l) = typ.check in
        put_line ob l f;
        fprintf ob "    const %s %s = %s;\n" ctype name (tplize c (string_of_int i))
      ) else (
        match typ.ctor with
        | None ->
          let (c, f, l) = typ.check in
          put_line ob l f;
          fprintf ob "    %s %s = %s;\n" ctype name (tplize c (string_of_int i))
        | Some (ctor, f, l) ->
          let v =
            let c, f, l = typ.check in
            tplize (sprintf "\n#line %d \"%s\"\n        %s" l f c)
              (string_of_int i)
          in
          put_line ob l f;
          fprintf ob "    %s %s = %s;\n" ctype name (tplize ctor v)
      ); i
    ) 0 fn.args);
    fprintf ob "\n#define RAISE(s)  luaL_error(L, (s))\n";
    if fn.rettype = [] then (
      fprintf ob "#define RETURN()  return luaM_ret_%s_%s(L)\n" pkg.name fn.fname
    ) else (
      fprintf ob "#define RETURN(luaM_x1";
      for i = 2 to retlen do fprintf ob ", luaM_x%d" i done;
      fprintf ob ") \\\n        return luaM_ret_%s_%s(L" pkg.name fn.fname;
      for i = 1 to retlen do fprintf ob ", luaM_x%d" i done;
      fprintf ob ")\n"
    );
    put_line ob l f;
    fprintf ob "    %s\n#undef RAISE\n#undef RETURN\n}\n" fn.body

  let do_c ob =
    let do_c_aux = function
      | Buf (s, f, l) -> put_line ob l f; output_string ob s
      | Pkg pkg       ->
          (* dump struct const init *)
          (if pkg.static then
            dump_struct_type ob "static " pkg (sprintf " %s = {\n" pkg.name)
          else
            fprintf ob "struct luaM_%s_t %s = {\n" pkg.name pkg.name
          );
          List.iter (function (m, _, _) ->
              let (init, f, l) = m.init in
              put_line ob l f;
              fprintf ob "    %s,\n" (if fst m.typ then init else "0")
            ) pkg.members;
          fprintf ob "};\n";

          (* dump struct init func *)
          fprintf ob "\nstatic void %s_init(void)\n{\n" pkg.name;
          List.iter (function (m, _, _) ->
            if not (fst m.typ) then
              let init, f, l = m.init in
              let field = sprintf "%s.%s" pkg.name m.mname in
              put_line ob l f;
              fprintf ob "    %s = %s;\n" field init;
              match m.onchange with
              | None           -> ()
              | Some(on, f, l) ->
                  put_line ob l f; fprintf ob "    %s;\n" (tplize on field)
            ) pkg.members;
          fprintf ob "};\n\n";

          (* dump __index *)
          fprintf ob "static int luaM_%s_index(lua_State *L)\n{\n" pkg.name;
          fprintf ob "    const char *idx = luaL_checkstring(L, 2);\n\n";
          fprintf ob "    switch (mlua_which_token(idx, -1)) {\n";
          List.iter (function (m, _, _) ->
            fprintf ob "      case LTK_%s:\n" (upper m.mname);
            let push, f, l = (snd m.typ).push in
            put_line ob l f;
            fprintf ob "        %s;\n" (tplize push (sprintf "%s.%s" pkg.name m.mname));
            fprintf ob "        return 1;\n"
          ) pkg.members;
          fprintf ob "      default:\n";
          fprintf ob "        lua_rawget(L, lua_upvalueindex(1));\n";
          fprintf ob "        return 1;\n";
          fprintf ob "    }\n}\n\n";

          (* dump __newindex *)
          fprintf ob "static int luaM_%s_newindex(lua_State *L)\n{\n" pkg.name;
          fprintf ob "    const char *idx = luaL_checkstring(L, 2);\n\n";
          fprintf ob "    switch (mlua_which_token(idx, -1)) {\n";
          List.iter (function (m, _, _) ->
            let field = sprintf "%s.%s" pkg.name m.mname in
            match m.typ with
            | true, _ -> ()
            | false, t ->
              fprintf ob "      case LTK_%s:\n" (upper m.mname);
              (match t.dtor with
              | None -> ()
              | Some (dtor, f, l) ->
                  put_line ob l f;
                  fprintf ob "        %s;\n" (tplize dtor ("&" ^ field))
              );
              (match t.ctor with
              | None ->
                  let (c, f, l) = t.check in
                  put_line ob l f;
                  fprintf ob "        %s = %s;\n" field (tplize c "3")
              | Some (ctor, f, l) ->
                  let v =
                    let c, f, l = t.check in
                    tplize (sprintf "\n#line %d \"%s\"\n            %s" l f c) "3"
                  in
                  put_line ob l f;
                  fprintf ob "        %s = %s;\n" field (tplize ctor v)
              );
              (match m.onchange with
              | None           -> ()
              | Some(on, f, l) ->
                  put_line ob l f;
                  fprintf ob "        %s;\n" (tplize on field)
              );
              fprintf ob "        return 1;\n"
          ) pkg.members;
          fprintf ob "      default:\n";
          fprintf ob "        lua_rawset(L, lua_upvalueindex(1));\n";
          fprintf ob "        return 1;\n";
          fprintf ob "    }\n}\n";

          (* dump methods *)
          List.iter (do_func ob pkg) pkg.methods;
          fprintf ob "\nstatic const luaL_reg luaM_%s_methods[] = {\n" pkg.name;
          List.iter (function (f, _, _) ->
              fprintf ob "    { \"%s\", luaM_%s_%s },\n" f.fname pkg.name f.fname)
            pkg.methods;
          output_string ob (Str.global_replace (Str.regexp "%s") pkg.name
"    { NULL, NULL },
};

int luaopen_%s(lua_State *L)
{
    int mt, members, methods;

    %s_init();

    /* create methods table, add it the the table of globals */
    luaL_openlib(L, \"%s\", luaM_%s_methods, 0);
    methods = lua_gettop(L);

    lua_newtable(L);                            /* for new members   */
    members = lua_gettop(L);

    /* create metatable for %s, add it to the registry */
    luaL_newmetatable(L, \"%s\");
    mt = lua_gettop(L);

    lua_pushliteral(L, \"__index\");
    lua_pushvalue(L, members);                  /* upvalue  1        */
    lua_pushcclosure(L, &luaM_%s_index, 1);
    lua_rawset(L, mt);                          /* set mt.__index    */

    lua_pushliteral(L, \"__newindex\");
    lua_pushvalue(L, members);                  /* upvalue  1        */
    lua_pushcclosure(L, &luaM_%s_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, 3);
    return 1;
}

")
    in List.iter do_c_aux

(* }}} *)

  let usage () =
    output_string stderr "usage: cpkg2c file.cpkg header.out source.out\n";
    exit 1

  let warn ob = output_endline ob "/*** THIS FILE IS AUTOGENERATED !!! ***/"

  let process fn file l =
    try Unix.unlink file with _ -> ();
    let ob = open_out_gen  [ Open_trunc ; Open_wronly; Open_creat ] 0o444 file in
    warn ob; fn ob l; close_out ob

  let _ =
    if Array.length Sys.argv != 4 then usage();
    let file   = Sys.argv.(1) in
    let lexbuf = L.from_channel (open_in file) in
    let l      = (startchunk cLine file lexbuf) in
    process do_h Sys.argv.(2) l;
    process do_c Sys.argv.(3) l
}