// This module contains a further set of utility functions, which are
// to a greater or lesser extent generated.  Both this file and the
// file generated from it include Ünicöde characters, which should be
// encoded in UTF-8.
//
// This file is part of Beastie <https://purl.org/nxg/dist/beastie>
// SPDX-FileCopyrightText: 2023 Norman Gray <https://nxg.me.uk>
// SPDX-License-Identifier: BSD-2-Clause

#include <string.h>
#include <stdlib.h>
//#include <stdio.h>              // debugging only

#include "beastie.h"
#include "util-extra.h"

#if 0
// remove this, when I remove the lex/yacc-generated subtex parser
typedef struct {
    const char* cs;
    const int cslen;
    const codepoint_t arg;
    const codepoint_t cp;
    const char* str;
} csarg_value_t;

// Compare two pointers to csarg_value_t, for bsearch.
// Note: strncmp is specified to work for null-terminated strings,
// which means we can't use it to compare two strings of unequal length.
static int compare_csarg_element(const void* e1_ptr, const void* e2_ptr)
{
    const csarg_value_t* e1 = (const csarg_value_t*)e1_ptr;
    const csarg_value_t* e2 = (const csarg_value_t*)e2_ptr;
    int res;

    if (e1->cslen == e2->cslen) {
        res = strncmp(e1->cs, e2->cs, e1->cslen);
    } else {
        size_t shorter = (e1->cslen < e2->cslen ? e1->cslen : e2->cslen);
        res = strncmp(e1->cs, e2->cs, shorter);
        if (res == 0) res = (e1->cslen < e2->cslen ? -1 : +1);
    }
    if (res == 0) {
        res = e1->arg - e2->arg;
    }

    //fprintf(stderr, "compare '%.*s'+%d < '%.*s'+%d => %d\n", e1->cslen, e1->cs, e1->arg, e2->cslen, e2->cs, e2->arg, res);
    return res;
}

static csarg_value_t* lookup_accented_char_base(const char* s, int slen, codepoint_t arg)
{
    #(let* ((char-file "misc/unicode/characters.scm")
            ;; this file is a list of
            ;; (codepoint char-as-string description "cs" [arg as char or int] ...)
            ;; where the last two parameters can be repeated
            ;; to indicate alternate cs+arg pairs
            (char-specs (with-input-from-file char-file read))
            #;(char-specs (map (lambda (spec)
                              `(,(car spec) ,(cadr spec) . ,(cdddr spec)))
                             (with-input-from-file char-file read))))
                                        ;(dependency-add! char-file)

       (let ((chars (sort!
                     (let loop ((ss char-specs)
                                (res '()))
                       ;; turn ((codepoint char-as-string ignored "cs" ...) ...)
                       ;; into ("cs" arg/int codepoint char-as-string)...
                       (if (null? ss)
                           res
                           (let ((cp (caar ss))
                                 (ch (cadar ss))
                                 (cslist (cdddar ss)))
                             (case (length cslist)
                               ((1) (loop (cdr ss)
                                          (cons (list (car cslist) 0 cp ch)
                                                res)))
                               ((2) (let ((cs (car cslist))
                                          (arg (cadr cslist)))
                                      (loop (cdr ss)
                                            (cons (list cs
                                                        (if (char? arg)
                                                            (char->integer arg)
                                                            arg)
                                                        cp
                                                        ch)
                                                  res))))
                               (else (let ((cs (car cslist))
                                           (arg (cadr cslist)))
                                       (loop `((,cp ,ch #f . ,(cddr cslist))
                                               . ,(cdr ss))
                                             (cons (list cs
                                                         (if (char? arg)
                                                             (char->integer arg)
                                                             arg)
                                                         cp
                                                         ch)
                                                   res))))))))
                     (lambda (a b)
                       ;; sort by "cs", then arg
                       (if (string=? (car a) (car b))
                           (< (cadr a) (cadr b))
                           (string<? (car a) (car b)))))))

         (list
          (format #f "static csarg_value_t lookup[] = {")
          (map (lambda (l)
                 (format #f "~%        { ~s, ~a, ~a, ~a, ~s }," (car l) (string-length (car l)) (cadr l) (caddr l) (cadddr l)))
               chars)
          (format #f "};~%    static const int nlookup = ~a;~%" (length chars)))))

    const csarg_value_t srch = { s, slen, arg, 0, NULL };
    csarg_value_t* result = bsearch(&srch,
                                    lookup, nlookup, sizeof(csarg_value_t),
                                    &compare_csarg_element);

    // fprintf(stderr, "lookup_accented_char_base(%.*s, %d) -> %s\n", slen, s, arg,
    //         (result == NULL ? "<>" : result->str));

    return result;
}

codepoint_t lookup_accented_char_as_cp(const char* s, int slen, codepoint_t arg)
{
    csarg_value_t* res = lookup_accented_char_base(s, slen, arg);
    return (res == NULL ? 0 : res->cp);
}
const char* lookup_accented_char_as_string(const char* s, int slen, codepoint_t arg)
{
    csarg_value_t* res = lookup_accented_char_base(s, slen, arg);
    return (res == NULL ? NULL : res->str);
}
#endif
// end of C-based command-lookup.
// (discarded, since I don't _think_ I'll need this again, but I'm not positive)

void load_runtime(void)
{
    #(file->strings "config.scm")
    s7_load_c_string(S7, config_scm, config_scm_len);

    #(file->strings "runtime.scm")
    s7_load_c_string(S7, runtime_scm, runtime_scm_len);

#include "readermacros.inc"
    s7_load_c_string(S7, readermacros_scm, readermacros_scm_len);

    #(let ((char-specs (with-input-from-file
                           "misc/unicode/characters.scm"
                         read)))
       (dependency-add! "misc/unicode/characters.scm")
       ;; this is a list of, eg,
       ;; (#xa3 "£" "POUND SIGN" "pounds")
       ;; or
       ;; (#xc0 "À" "LATIN CAPITAL LETTER A WITH GRAVE" "`" #\A)
       ;; where the contents after the description indicate either
       ;; (i) a single TeX command, such as "\pounds" or a command argument
       ;; pair such as (here) "\`{A}", and there can be multiple such
       ;; pairs.
       ;;
       ;; Turn these into a definition of %subtex-mappings% which
       ;; is a vector of
       ;; (string? . integer?) or (string? . (vector-of (integer? . integer?))).
       ;; The first is a mapping (eg) "\pounds" -> 163,
       ;; the second is "`" -> #(... (#x41 . #xc0)...)
       (let* ((charmap
               (sort! (map (lambda (cs)
                             (let ((codepoint (car cs))
                                   (char-as-string (cadr cs))
                                   (commands (cdddr cs)))
                               (if (= (length commands) 1)
                                   (list (car commands)
                                         codepoint)
                                   (apply values
                                          (let loop ((cmds commands))
                                            (cond ((null? cmds) '())
                                                  ((null? (cdr cmds)) (error "unexpected end of list ~s" commands))
                                                  (else
                                                   `((,(car cmds)
                                                      ,(cadr cmds)
                                                      ,codepoint)
                                                     . ,(loop (cddr cmds))))))))))
                           char-specs)
                      (lambda (a b)
                        (string<? (car a) (car b))))))
         (define (make-subkey-vector l)
           ;; given a list of (c . integer?), where c is char? or integer?,
           ;; return a vector of (ci . integer?), where ci is either c or (char->integer c)
           (list->vector
            (sort! (map (lambda (p)
                          (let ((ci (car p)))
                            (cons
                             (if (char? ci)
                                 (char->integer ci)
                                 ci)
                             (cdr p))))
                        l)
                   (lambda (a b)
                     (< (car a) (car b))))))
         (let* ((prog
                (let loop ((c charmap)
                           (result '())
                           (sublist-key #f)
                           (sublist-value '()))
                  (if (null? c)
                      (if sublist-key
                          (loop '()
                                (cons (cons sublist-key
                                            (make-subkey-vector sublist-value))
                                      result)
                                #f #f)
                          (reverse result))
                      (let ((c1 (car c)))
                        (cond ((= (length c1) 2)
                               (if sublist-key
                                   (loop c
                                         (cons (cons sublist-key (make-subkey-vector sublist-value))
                                               result)
                                         #f #f)
                                   (loop (cdr c)
                                         `((,(car c1) . ,(cadr c1)) . ,result)
                                         #f #f)))
                              (sublist-key
                               (if (string=? (car c1) sublist-key)
                                   (loop (cdr c)
                                         result
                                         sublist-key
                                         `((,(cadr c1) . ,(caddr c1)) . ,sublist-value))
                                   (loop c
                                         (cons (cons sublist-key
                                                     (make-subkey-vector sublist-value))
                                               result)
                                         #f #f)))
                              (else
                               (loop (cdr c)
                                     result
                                     (car c1)
                                     `((,(cadr c1) . ,(caddr c1))))))))))
               (progstr
                (let-temporarily (((*s7* 'print-length) (*s7* 'most-positive-fixnum)))
                  (call-with-output-string
                   (lambda (out)
                     (write `(define %subtex-mappings% ,(list->vector prog)) out))))))
           (prog->strings (list progstr) "subtex_mappings" #t))))

    // fprintf(stderr, "subtex_mappings[%lu] = <%.40s...%d>\n", subtex_mappings_len, subtex_mappings,
    //         subtex_mappings[subtex_mappings_len]);
    s7_load_c_string(S7, subtex_mappings, subtex_mappings_len);
}

const char* get_module_content(const char* module_name, size_t* string_length)
{
    struct module_list_s {
        const char* name;
        const char* content;
        size_t content_length;
    };
    #(let ((files '((authors . "authors.scm")
                    (aux . "parse-aux.scm")
                    (bibtex . "bibtex.scm")
                    (parse-bib2* . "parse-bib2.scm")
                    (bst . "bst.scm")
                    (markdown . "parse-markdown.scm")
                    (utils . "scheme-utils.scm")
                    (xexpr . "xexpr.scm")
                    (klipspringer . "klipspringer.scm")
                    (klipspringer/structs
                     ;; As with 'klipspringer, but _including_ the struct procedures,
                     ;; which are not otherwise provided from klipspringer.
                     ;; This isn't currently documented/exposed:
                     ;; the time to do that would be when overhauling
                     ;; the doc/klipspringer.md documentation.
                     (let ((expose
                            '(make-empty empty? empty-result
                                         make-consumed consumed? consumed-result
                                         make-ok ok? ok-value ok-input
                                         make-error error? error-descriptions error-inputs
                                         make-parser-input input-car input-cdr))
                           (*module-name* "internal-for-klipspringer-structs"))

                       (module/expose 'klipspringer)
                       ;; now add the exposed procedures to the local *provides* let,
                       ;; and define *provides* in the outer let to be this extended one
                       (varlet (outlet (curlet))
                               '*provides*
                               (apply varlet
                                      (cons *provides*
                                            (apply append
                                                   (map (lambda (s)
                                                          (list s (eval s)))
                                                        expose)))))))
                    (mdblock . "parse-mdblock.scm")
                    (json . "parse-json.scm")
                    (subtex . "parse-subtex.scm")
                    (subtex*
                     ;; Within this module, we define a separate *provides*-like let.
                     ;; This is similar to 'subtex, but adds management procedures
                     ;; which should only by used by beastie code
                     (let ()
                       (module/expose 'subtex)
                       (varlet (outlet (curlet))
                               '*provides* *provide-in-starred-version*)))
                    (unicode . "unicode.scm"))))
       (let ((modules
              (map (lambda (spec)
                     (let ((content (cdr spec))
                           (ident (car spec))
                           (name (format #f "~a_module"
                                         (list->string
                                          (map (lambda (c)
                                                 ;; very simple canonicalisation to C symbol
                                                 (if (or (char-alphabetic? c)
                                                         (char-numeric? c))
                                                     c
                                                     #\_))
                                               (string->list
                                                (symbol->string (car spec))))))))
                       (if (list? content)
                           (cons (cons
                                  (format #f "~%~%/* inline code for ~a */" ident)
                                  (prog->strings
                                   (let-temporarily (((*s7* 'print-length)
                                                      (*s7* 'most-positive-fixnum)))
                                     (map (lambda (line)
                                            (call-with-output-string
                                             (lambda (out)
                                               (write line out))))
                                          content))
                                   name
                                   :static? #t
                                   :comment-length 100))
                                 (format #f "        { \"~a\", ~a, ~a_len }, /* inline */~%"
                                         ident name name))
                           (cons (file->strings content name :static? #t)
                                 (format #f "        { \"~a\", ~a, ~a_len }, /* ~a */~%"
                                         ident name name content)))))
                   files)))
         (apply append
                (map car modules)
                (list (format #f "~%~%    static struct module_list_s modules[] = {~%"))
                (map cdr modules)
                (list (format #f "    };~%    static size_t modules_len = ~a;~%" (length files))))))

    for (int i=0; i<modules_len; i++) {
        if (strcmp(module_name, modules[i].name) == 0) {
            *string_length = modules[i].content_length;
            return modules[i].content;
        }
    }
    return NULL;
}