// This is a by-hand lexer for .bib files.
//
// The function lex1(s7_scheme*, biblex_t) returns an s7 list,
// the car of which is a symbol indicating the lexeme, and the cdr of
// which is a list of unicode codepoints as integers.
//
// This is a shade more intricate than I might have thought, but only
// slightly, and the flex version of this would be not much simpler,
// as well as involving something of a hack in terms of wranging UTF8.
//
// This file is part of Beastie <https://purl.org/nxg/dist/beastie>
// SPDX-FileCopyrightText: 2025 Norman Gray <https://nxg.me.uk>
// SPDX-License-Identifier: BSD-2-Clause


#if __GNUC__
// for asprintf
#define _GNU_SOURCE
#endif

#include <stdio.h>
#include <string.h>
#include <ctype.h>
#include <assert.h>

#include "s7.h"

#include "config.h"
#include "util.h"
#include "unicode.h"
#include "unicode-scm.h"
#include "uniprops.h"

// for debugging purposes, define WITH_MAIN to non-zero to make a
// standalong program
#ifndef WITH_MAIN
#define WITH_MAIN 0
#endif

#define GCP(x) s7_gc_protect_via_stack(S7, x)

struct biblex_s {
    s7_pointer r_scm;           // hold on to this, so we can mark it
    unicode_reader* r;          // = s7_c_object_value(r_scm), for convenience
    codepoint_t entry_end_char;
    enum { outside_entry,       // outside entries, looking for '@'
           inside_entry,        // inside @foo{...}
           looking_for_start_of_entry // after @foo but before '{'
    } state;
};
typedef struct biblex_s* biblex_t;

static void free_biblex(biblex_t p)
{
    // note that, here, we must _not_ free the unicode_reader p->r,
    // since that's managed by the s7 object r_scm,
    // which we're holding on to so we can mark it when necessary

    p->r = NULL;
    p->r_scm = NULL;
    free(p);
    return;
}

static biblex_t make_biblexer(s7_scheme* sc, s7_pointer reader_scm)
{
    biblex_t lexer = malloc(sizeof(struct biblex_s));
    if (lexer == NULL) {
        error_exit("Can't allocate %lld bytes for biblex_t", sizeof(struct biblex_s));
    }

    // internal procedure: we assume that reader_scm is indeed a reader object
    if (! is_unicode_reader_p(reader_scm)) {
        s7_wrong_type_arg_error(sc, "make-biblex*", 1, reader_scm, "a unicode-reader?");
        // NOTREACHED
        return NULL;
    }

    lexer->r_scm = reader_scm;
    unicode_reader* rdr = (unicode_reader*)s7_c_object_value(reader_scm);
    lexer->r = rdr;
    lexer->entry_end_char = '\0';
    lexer->state = outside_entry;

    return lexer;
}

// Read a single codepoint from the reader,
// handling bad decodes with a warning message.
// Thus this will return a codepoint, UNICODE_EOF, or UNICODE_REPLACEMENT_CHARACTER.
static codepoint_t read1(unicode_reader* reader)
{
    const char* errmsg;
    codepoint_t cp = unicode_reader_next_cp(reader, &errmsg);
    if (cp == UNICODE_BAD_DECODE) {
        scheme_eval("print-warning",
                    s7_make_string(S7, "mangled Unicode read: ~a"),
                    s7_make_string(S7, errmsg),
                    NULL);
        cp = UNICODE_REPLACEMENT_CHARACTER;
    }
    return cp;
}

// read from the reader until we have something that isn't a space,
// taking all comments to be spaces
static codepoint_t read_skipping_spaces(unicode_reader* reader)
{
    codepoint_t cp;
    do {
        cp = read1(reader);
        if (cp == UNICODE_EOF) return UNICODE_EOF;
        if (cp == '%') {
            // Unicode-aware line-ending (clearly being a bit
            // obsessive here...).
            //
            // The Unicode Line Breaking Algorithm
            // <https://www.unicode.org/reports/tr14/tr14-32.html> has
            // rather more to say about this than you might expect,
            // but it boils down to:
            //
            //   * form-feed/FF (U+0c), vertical tab/VT (U+0b), line separator
            //     (U+2028) and paragraph separator (U+2029) are mandatory
            //     break characters (BK).
            //
            //   * NEL (U+0085), LF and CR require breaks after, but not
            //     between CR and LF.
            //
            // JSON is simple-minded, of course, and recognises only
            // LR and CRLF (because it regards only space, HT, LF and
            // CR as whitespace), and YAML agrees (though slightly
            // reluctantly, and only to remain compatible with JSON).
            // https://datatracker.ietf.org/doc/html/rfc7159#section-2
            // https://yaml.org/spec/1.2-old/spec.html#id2774608
            //
            // In this particular context, it's fine to normalise all
            // of these to a '\n', since we are simply skipping
            // whitespace here.
            while (cp != '\n') {
                cp = read1(reader);
                if (cp == UNICODE_EOF) return UNICODE_EOF; // JUMP OUT
                switch (cp) {
                  case '\r':
                    cp = read1(reader);
                    if (cp != '\n') {
                        push_codepoint(reader, cp);
                        cp = '\n'; // normalise CRLF to LF
                    }
                    break;

                  case 0x0b:    // VT
                  case 0x0c:    // FF
                  case 0x0085:  // NEL
                  case 0x2028:  // LS
                  case 0x2029:  // PS
                    cp = '\n';
                    break;
                }
            }
        }
    } while (UNIPROP_FUNC(space_p)(cp));
    return cp;
}

// Return one lexeme as (type . lvalue), or NULL at end-of-stream.
// The lvalues are all ustring?
//
// If we find EOF _unexpectedly_, then that's EOF for this function,
// so return NULL.
s7_pointer lex1(s7_scheme* sc, biblex_t lexer)
{
    ustring_t us_result = NULL;
#define INIT_RESULT(cp) do {                                    \
        us_result = make_ustring(NULL);                         \
        ustring_append_cp(us_result, cp, NULL);                 \
    } while (0)
#define APPEND_RESULT(cp) ustring_append_cp(us_result, cp, NULL)

    // There are various places where we do not expect to read EOF.
    // If we find such, then set result to be NULL (which it should be
    // already), and jump to the end of the function.
#define BAIL_IF_EOF(cp) if ((cp) == UNICODE_EOF) {      \
        result = NULL;                                  \
        goto lex1_unexpected_eof;                       \
    }

    codepoint_t cp;

    s7_pointer result = NULL;
    unicode_reader* reader = lexer->r;

    // delimiters
    static const char* non_string_punctuation = ",=#{}()%";


 start_scanning:
    // we jump back here after reading @comment or an @ not followed by a letter

    cp = read_skipping_spaces(reader);

    // if the first thing we read is EOF, then that's EOF from this
    // function's point of view, too
    BAIL_IF_EOF(cp);

    if (lexer->state == outside_entry) {

        // outside of an entry, there is nothing to do other than search for an '@' sign
        if (cp != '@') {
            do {
                cp = read_skipping_spaces(reader);
                BAIL_IF_EOF(cp);
            } while (cp != '@');
        }

        cp = read_skipping_spaces(reader);
        BAIL_IF_EOF(cp);

        // The only lexical requirement we have is that the '@' is
        // followed by a letter.  The grammar imposes other
        // requirements, but these are not our concern.
        if (UNIPROP_FUNC(letter_p)(cp)) {
            INIT_RESULT(cp);

            int scanning_p = 1;
            while (scanning_p) {
                cp = read1(reader);
                if (cp == UNICODE_EOF || UNIPROP_FUNC(space_p)(cp)) {
                    scanning_p = 0;
                } else if (strchr(non_string_punctuation, cp) != NULL) {
                    push_codepoint(reader, cp);
                    scanning_p = 0;
                } else {
                    APPEND_RESULT(cp);
                }
            }

            // check to see if the 'entry type' is actually one of the
            // special forms
            enum { other, preamble, string, comment, include } entry_type;
            {
                static const size_t maxchars = 10; // longer than any of the special @type strings
                char entry_type_string[maxchars];
                int i;
                int slen = ustring_length(us_result);
                for (i=0; i<maxchars && i<slen; i++) {
                    codepoint_t cp = UNIPROP_FUNC(lowercase_character)(ustring_ref(us_result, i));
                    if (cp == 0 || cp >= 0x80) {
                        i = maxchars; // no match
                    } else {
                        entry_type_string[i] = cp;
                    }
                }
                if (i == maxchars) {
                    entry_type = other;
                } else {
                    entry_type_string[i] = '\0';
                    if (strcmp(entry_type_string, "preamble") == 0) {
                        entry_type = preamble;
                    } else if (strcmp(entry_type_string, "string") == 0) {
                        entry_type = string;
                    } else if (strcmp(entry_type_string, "comment") == 0) {
                        entry_type = comment;
                    } else if (strcmp(entry_type_string, "include") == 0) {
                        entry_type = include;
                    } else {
                        entry_type = other;
                    }
                }
            }

            switch (entry_type) {
              case comment:
                {
                    // gobble a {...} or (...) argument and go back for another try
                    // It might be more sensible to simply return @comment
                    // here, and let the grammar skip this.  However, we want
                    // to be sure that arbitrary garbage inside the @comment
                    // is skipped, including things that look a lot like
                    // entries, and it seems more robust to do that here,
                    // requiring only that the comment have balanced braces.
                    int open_brace;
                    int close_brace;

                    cp = read_skipping_spaces(reader);
                    BAIL_IF_EOF(cp);

                    if (cp == '{' || cp == '(') {
                        // gobble @comment{...}
                        if (cp == '{') {
                            open_brace = '{';
                            close_brace = '}';
                        } else {
                            open_brace = '(';
                            close_brace = ')';
                        }

                        int brace_level = 1;
                        scanning_p = 1;
                        while (scanning_p) {
                            cp = read1(reader);
                            BAIL_IF_EOF(cp); // EOF within comment

                            if (cp == open_brace) {
                                brace_level++;
                            } else if (cp == close_brace) {
                                brace_level--;
                                if (brace_level == 0) {
                                    scanning_p = 0;
                                }
                            }
                        }

                    } else {
                        // @comment with no {...} after it
                        push_codepoint(reader, cp);
                    }
                    // discard the string we have in us_result
                    // (because it has turned out to be redundant)
                    assert(us_result != NULL);
                    ustring_free(us_result);
                    us_result = NULL;

                    // an alternative, to avoid a goto, is to recurse
                    // here, but simply leaping back to the beginning of
                    // the function seems clearer in C terms
                    goto start_scanning;

                }
                break;

              case preamble:
                result = s7_list(sc, 1, s7_make_symbol(sc, "preamble"));
                lexer->state = looking_for_start_of_entry;
                break;
              case include:
                result = s7_list(sc, 1, s7_make_symbol(sc, "include"));
                lexer->state = looking_for_start_of_entry;
                break;
              case string:
                result = s7_list(sc, 1, s7_make_symbol(sc, "stringdef"));
                lexer->state = looking_for_start_of_entry;
                break;

              default: // other
                // this is the normal case
                result = s7_cons(sc,
                                 s7_make_symbol(sc, "entry-type"),
                                 make_ustring_obj(sc, us_result));
                lexer->state = looking_for_start_of_entry;
                // special case: move to the looking_for_start_of_entry state.
                // In this state, the next '{' is _not_ a
                // quoted-string, but the open brace which surrounds the entry
                break;
            }
        } else {
            // no string (starting with a letter) after the '@':
            push_codepoint(reader, cp);
            // pretend this didn't happen
            // (ie, in effect regard it as part of inter-entry text)
            goto start_scanning;

        }

    } else  {

        if (lexer->state == looking_for_start_of_entry
            && (cp == '{' || cp == '(')) {
            lexer->entry_end_char = (cp == '{' ? '}' : ')');
            result = s7_list(sc, 1, s7_make_symbol(sc, "entry-open-brace"));
            lexer->state = inside_entry;
            // the looking_for_start_of_entry state treats '{' and '('
            // specially, but should treat all other lexemes as in
            // inside_entry.  These will be grammar errors (which
            // we'll catch subsequently), but are not lexical ones.

        } else if (cp == '}' || cp == ')') {
            // force this to match entry_end_char?
            result = s7_list(sc, 1, s7_make_symbol(sc, "entry-close-brace"));
            lexer->state = outside_entry;

        } else if (cp == '=') {
            result = s7_list(sc, 1, s7_make_symbol(sc, "equals"));

        } else if (cp == ',') {
            result = s7_list(sc, 1, s7_make_symbol(sc, "comma"));

        } else if (cp == '#') {
            result = s7_list(sc, 1, s7_make_symbol(sc, "hash"));

        } else if (cp == '"' || cp == '{') {
            codepoint_t end_char = (cp == '"' ? '"' : '}');

            cp = read1(reader);
            if (cp == end_char) {
                // empty string
                result = s7_cons(sc,
                                 s7_make_symbol(sc, "quoted-string"),
                                 make_ustring_obj(sc, make_ustring(NULL)));

            } else {
                INIT_RESULT(cp);

                int brace_level = 0;
                if (cp == '{') brace_level++; // string starts with '{'

                int scanning_p = 1;
                int escaped_p = 0;

                do {
                    cp = read1(reader);
                    BAIL_IF_EOF(cp); // EOF within a string

                    if (escaped_p) {
                        APPEND_RESULT(cp);
                        escaped_p = 0;
                    } else if (cp == '\\') {
                        APPEND_RESULT(cp);
                        escaped_p = 1;
                    } else if (cp == end_char && brace_level == 0) {
                        scanning_p = 0;
                    } else {
                        if (cp == '{') {
                            brace_level++;
                        } else if (cp == '}') {
                            brace_level--;
                        }
                        APPEND_RESULT(cp);
                    }
                } while (scanning_p);

                result = s7_cons(sc,
                                 s7_make_symbol(sc, "quoted-string"),
                                 make_ustring_obj(sc, us_result));
            }

        } else {
            INIT_RESULT(cp);
            int scanning_p = 1;
            while (scanning_p) {
                cp = read1(reader);
                if (cp == UNICODE_EOF || UNIPROP_FUNC(space_p)(cp)) {
                    scanning_p = 0;
                } else if (strchr(non_string_punctuation, cp) != NULL) {
                    push_codepoint(reader, cp);
                    scanning_p = 0;
                } else {
                    APPEND_RESULT(cp);
                }
            }

            result = s7_cons(sc,
                             s7_make_symbol(sc, "unquoted-string"),
                             make_ustring_obj(sc, us_result));
        }
    }

 lex1_unexpected_eof:           // various places jump to here on EOF

    if (result != NULL) {
        // This is, I think, typically redundant, since the object is
        // likely to be referred to by scheme code soon enough that it
        // would be exempt for garbage-collection.  But let's not
        // depend on that.
        s7_gc_protect_via_stack(sc, result);
    }

    return result;

#undef INIT_RESULT
#undef APPEND_RESULT
#undef BAIL_IF_EOF
}


// s7 implementation of the object
static int biblex_type_tag = 0;

static int is_biblex_p(s7_pointer obj)
{
    return s7_is_c_object(obj)
        && s7_c_object_type(obj) == biblex_type_tag;
}

s7_pointer is_biblex_proc(s7_scheme* sc, s7_pointer args)
{
    // args is of length 1
    return s7_make_boolean(sc, is_biblex_p(s7_car(args)));
}

static s7_pointer free_biblex_object(s7_scheme* sc, s7_pointer obj)
{
    biblex_t biblex = (biblex_t)s7_c_object_value(obj);
    free_biblex(biblex);
    return NULL;
}

static s7_pointer mark_biblex_object(s7_scheme* sc, s7_pointer obj)
{
    biblex_t biblex = (biblex_t)s7_c_object_value(obj);
    s7_mark(biblex->r_scm);
    return NULL;
}

static s7_pointer biblex_is_equal_proc(s7_scheme* sc, s7_pointer args)
{
    s7_pointer a1 = s7_car(args);
    s7_pointer a2 = s7_cadr(args);

    int result;

    if (!is_biblex_p(a1) || !is_biblex_p(a2)) {
        result = 0;
    } else {
        biblex_t l1 = (biblex_t)s7_c_object_value(a1);
        biblex_t l2 = (biblex_t)s7_c_object_value(a2);
        result = unicode_reader_same_source_p(sc, l1->r, l2->r);
    }

    return result ? s7_t(sc) : s7_f(sc);
}

static s7_pointer biblex_to_string_proc(s7_scheme* sc, s7_pointer args)
{
    // I think we're guaranteed this will be a lexer
    s7_pointer lexer_object = s7_car(args);

    biblex_t lexer = (biblex_t)s7_c_object_value(lexer_object);
    s7_pointer location = unicode_reader_location(sc, lexer->r);

    char* msg;
    if (asprintf(&msg, "<biblex:%s>", s7_string(location)) < 0) {
        // out of memory!
        error_exit("out of memory trying to get a name for a lexer!");
    }
    s7_pointer result = s7_make_string(sc, msg);
    free(msg);
    return result;
}

static s7_pointer biblex_read_proc(s7_scheme* sc, s7_pointer args)
{
    s7_pointer lexer_object = s7_car(args);
    s7_pointer optarg = (s7_list_length(sc, args) > 1 ? s7_cadr(args) : NULL);

    if (! is_biblex_p(lexer_object)) {
        return s7_wrong_type_arg_error(sc, "biblex-read", 1, lexer_object, "a biblexer?");
    }

    s7_pointer result;

    biblex_t lexer = (biblex_t)s7_c_object_value(lexer_object);

    if (optarg) {
        if (s7_is_symbol(optarg)
                && strcmp(s7_symbol_name(optarg), "location") == 0) {
            result = unicode_reader_location(sc, lexer->r);
        } else {
            return s7_wrong_type_arg_error(sc, "biblex-read", 2, optarg,
                                           "a symbol 'location");
        }
    } else {
        result = lex1(sc, lexer);
    }

    if (result == NULL) {
        return s7_eof_object(sc);
    } else {
        return result;
    }
}

s7_pointer make_biblex_proc(s7_scheme* sc, s7_pointer args)
{
    s7_pointer reader = s7_car(args);
    if (! is_unicode_reader_p(reader)) {
        return s7_wrong_type_arg_error(sc, "make-biblex*", 1, reader, "a unicode-reader?");
    }

    // if make_biblexer fails, it exits
    return s7_make_c_object(sc,
                            biblex_type_tag,
                            (void*)make_biblexer(sc, reader));
}

s7_pointer biblex_load_hook(s7_scheme* sc, s7_pointer args)
{
    if (biblex_type_tag != 0) {
        // been here before
        return args;
    }

    biblex_type_tag = s7_make_c_type(sc, "biblex");
    s7_c_type_set_gc_free(sc, biblex_type_tag, free_biblex_object);
    s7_c_type_set_gc_mark(sc, biblex_type_tag, mark_biblex_object);
    s7_c_type_set_is_equal(sc, biblex_type_tag, biblex_is_equal_proc);
    s7_c_type_set_to_string(sc, biblex_type_tag, biblex_to_string_proc);
    s7_c_type_set_ref(sc, biblex_type_tag, biblex_read_proc);

#if WITH_MAIN
    // these are defined in core.c normally, but we define them here
    // in order to let with WITH_MAIN version be standalone
    s7_define_function(sc, "make-biblex*", make_biblex_proc,
                       1, 0, false,
                       "`(make-biblex* unicode-reader?)` :create a lexer for .bib files, reading from the given reader");
    s7_define_function(sc, "biblex?", is_biblex_proc,
                       1, 0, false,
                       "`(biblex? x)` : return `#t` if `x` is a .bib file lexer");
#endif

    // no changes to the environment are required -- simply return arguments
    return args;
}

// main function
#if WITH_MAIN
#include <unistd.h>             // for getopt

s7_scheme* S7;

static const char* progname;
void Usage(int exit_status)
{
    fprintf(stderr, "Usage: %s file.bib\n       %s -s \"@article...\"\n", progname, progname);
    exit(exit_status);
}

int main(int argc, char** argv)
{
    progname = argv[0];

    int parse_string_p = 0;

    int ch;
    while ((ch = getopt(argc, argv, "sh")) != -1) {
        switch (ch) {
          case 's':
            parse_string_p = 1;
            break;
          case 'h':
            Usage(0);
            break;
          default:
            Usage(1);
        }
    }
    argc -= optind;
    argv += optind;

    if (argc == 0) Usage(1);
    const char* source = argv[0];

    S7 = s7_init();

    unicode_load_hook(S7, s7_nil(S7));

    // change this constant to swap back and forth between using
    // scheme functions to display/debug here
#if 1
    biblex_load_hook(S7, s7_nil(S7));

    s7_define_variable(S7, "*input-source*", s7_make_string(S7, source));
    s7_define_variable(S7, "*input-is-string?*", s7_make_boolean(S7, parse_string_p));
    s7_define_function(S7, "make-unicode-reader/string*",
                       make_unicode_reader_string_proc,
                       1, 0, false,
                       "create a unicode-reader");
    s7_define_function(S7, "make-unicode-reader/file*",
                       make_unicode_reader_file_proc,
                       1, 0, false,
                       "create a unicode-reader");
    s7_eval_c_string(S7,
                     "(let ((lexer"
                     "        (make-biblex*"
                     "          ((if *input-is-string?* make-unicode-reader/string* make-unicode-reader/file*)"
                     "           *input-source*))))"
                     "  (let loop ()"
                     "    (let ((lexeme (lexer)))"
                     "      (unless (eof-object? lexeme)"
                     "        (format #t \"l: ~s~%\" lexeme)"
                     "        (loop)))))");
#else
    biblex_t lexer;
    s7_pointer args = s7_list(S7, 2,
                              s7_make_string(S7, source),
                              s7_make_boolean(S7, 0));

    if (parse_string_p) {
        fprintf(stderr, "lex from string <%s>\n", source);
        lexer = make_biblexer(S7, make_unicode_reader_string_proc(S7, args));
    } else {
        lexer = make_biblexer(S7, make_unicode_reader_file_proc(S7, args));
    }

    // if there's a problem, this calls return_beastie_error, which
    // will probably cause this program to crash

    s7_pointer lexeme;
    while ((lexeme = lex1(S7, lexer)) != NULL) {
        s7_pointer lvalue = s7_cdr(lexeme);
        // lexeme is a s7 list
        if (s7_is_null(S7, lvalue)) {
            s7w(NULL, lexeme, "\n");
        } else {
            s7w(NULL, s7_car(lexeme), ": ");
            s7w(NULL, lvalue, "\n");
        }
    }
#endif
}
#endif /* WITH_MAIN */