;; Various unicode-supporting functions.
;;
;; These are generally fairly low-level functions, and quite a lot of
;; the functionality here is implemented in C code.
;;
;; 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

(define *requires-implementation-functions*
  '(unicode-load-hook*
    make-unicode-reader/file* make-unicode-reader/string*
    ustring-index*
    ustring-map-internal*
    ustring-cache-object-get* ustring-cache-object-set!*))
(define *provides-implementation-functions*
  '(unicode-reader? unicode-reader-source unicode-reader-location
                    unicode-reader-read
                    unicode-decode/utf8 unicode-decode1/port/utf8
                    unicode-encode/utf8 unicode-encode1/utf8
                    unicode-set-locale! unicode-get-locale unicode-get-locales
                    ustring? make-ustring
                    ustring-append ustring-append! ustring-length
                    ustring=? ustring<? ustring->hash
                    ustring-car ustring-ref ustring-substring
                    ustring->string ustring->symbol symbol->ustring))

(define-macro (%module-verbosity-flag%) 1024)

(define/provide* (make-unicode-reader/file fn (ascii-characters? #f))
  #"""`(make-unicode-reader/file fn ascii-characters?)` :
  make a unicode reader from a file `fn`.

  If `ascii-characters?` is true, then the reader will return codepoints
  below 0x80 as characters rather than integers.

  If the `fn` is `#f`, then this will read from stdin."""
  (make-unicode-reader/file* fn ascii-characters?))
(define/provide* (make-unicode-reader/string str (ascii-characters? #f))
  #"""`(make-unicode-reader/string fn ascii-characters?)` :
  make a unicode reader from a string `str`.

  If `ascii-characters?` is true, then the reader will return codepoints
  below 0x80 as characters rather than integers."""
  (make-unicode-reader/string* str ascii-characters?))

(define/provide (ustring-uppercase! us)
  "`(ustring-uppercase! us)` : convert the ustring contents to uppercase, in place, and return the argument"
  (ustring-map-internal* us 'uppercase))
(define/provide (ustring-lowercase! us)
  "`(ustring-lowercase! us)` : convert the ustring contents to lowercase, in place, and return the argument"
  (ustring-map-internal* us 'lowercase))
(define/provide (ustring-titlecase! us)
  "`(ustring-titlecase! us)` : convert the ustring contents to titlecase, in place, and return the argument"
  (ustring-map-internal* us 'titlecase))

(define/provide (ustring-uppercase us)
  "`(ustring-uppercase us)` : return a new ustring with the contents converted to uppercase"
  (ustring-uppercase! (make-ustring us)))
(define/provide (ustring-lowercase us)
  "`(ustring-lowercase us)` : return a new ustring with the contents converted to lowercase"
  (ustring-lowercase! (make-ustring us)))
(define/provide (ustring-titlecase us)
  "`(ustring-titlecase us)` : return a new ustring with the contents converted to titlecase"
  (ustring-titlecase! (make-ustring us)))

;;;; Caching
;;
;; The cache mechanism here relies on the
;; `ustring-cache-object-{get,set!}*` procedure, which manages a cache
;; which is erased any time the underlying ustring is changed (see unicode-scm.c).
(define/provide (ustring-cache-set!* us key value)
  #"""`(ustring-cache-set!* us key value)` : adds an entry to the cache
  cache associated with the string `us`.
  The key must be a symbol; the value can be anything.
  See also `ustring-cache-get*.`

  Any change to the underlying ustring, such as appending something to it,
  will invalidate the cache.

  The procedure evaluates to the `value`.

  This function is provided to the environment, because it has to be visible generally,
  but it is not documented and so not public."""
  (cond ((not (symbol? key))
         (error 'wrong-type-arg "ustring-cache-set!*: key must be a symbol, not ~s" key))
        ((ustring-cache-object-get* us)
         => (λ (cache)
              (cond ((assv key cache)
                     => (λ (p)
                          (set-cdr! p value)))
                    (else
                     (ustring-cache-object-set!* us (cons (cons key value) cache))
                     value))))
        (else
         (ustring-cache-object-set!* us (list (cons key value)))
         value)))

(define/provide (ustring-cache-get* us key)
  #"""`(ustring-cache-get* us key)` : retrieves the item keyed by `key` in the
  cache associated with the string `us`, or `#f` if the item is not present in the cache.
  See `ustring-cache-set!*`"""
  (cond ((ustring-cache-object-get* us)
         => (λ (cache)
              (cond ((assv key cache) => cdr)
                    (else #f))))
        (else #f)))

#;(define/provide (ustring-cache-get* us key)
  #"""`(ustring-cache-get* us key)` : retrieves the item keyed by `key` in the
  cache associated with the string `us`, or `#f` if the item is not present in the cache.
  See `ustring-cache-set!*`"""
  (cond ((ustring-cache-object-get* us)
         => (λ (cache)
              (cond ((assv key cache)
                     => (λ (p)
                          (print-info "cache hit: ~s -> ~s" key (cdr p))
                          (cdr p)))
                    (else
                     (print-info "cache miss1: ~s" key)
                     #f))))
        (else
         (print-info "cache miss2: ~s" key)
         #f)))

(define/provide* (ustring-index us cp (start 0) (end #f))
  #"""`(ustring-index us cp [:start 0] [:end #f])` :
  Return the index of the first character in the ustring? `us` which is equal to `cp`,
  where `cp` is an integer codepoint or a character,
  or a (integer? -> boolean?) procedure
  [similar to `string-index`, but with a more restricted form for `cp`.].

  The `:start` and `:end` keyword arguments delimit
  the scan, and default to the start and end of the string;
  these arguments are indexes into the string,
  with `end` indicating the index one past the last character to be considered;
  `end` may be `#f` to indicate the end of the string.

  Returns `#f` if the character is not present."""
  (unless (ustring? us)
    (error 'wrong-type-arg "ustring-index: first argument must be ustring?, not ~s" us))
  (unless (integer? start)
    (error 'wrong-type-arg "ustring-index: :start argument must be integer?, not ~s" start))
  (unless (or (integer? end) (not end))
    (error 'wrong-type-arg "ustring-index: :end argument must be integer?, not ~s" end))

  (cond ((integer? cp)
         (ustring-index* us cp start end))
        ((char? cp)
         (ustring-index* us (char->integer cp) start end))
        ((procedure? cp)
         ;; this may not be the most efficient way of doing this
         (let ((i (make-iterator us)))
           (let loop ((i0 (i))
                      (idx 0))
             (cond ((eof-object? i0) #f)
                   ((and end (= idx end)) #f)
                   ((< idx start) (loop (i) (+ idx 1)))
                   ((cp i0) idx)
                   (else (loop (i) (+ idx 1)))))))
        (else
         (error 'wrong-type-arg
                "ustring-index: second argument must be integer?, char?, or procedure?, not ~s"
                cp))))

(define/provide (ustring->list us)
  "`(ustring->list us)` : convert a ustring to a list of codepoints"
  (map values us))

;; the following implementation is slightly more general than it needs
;; to be, since it will/should/might work with any `s` that's iterable
;; and can return integers.
(define/provide (ustring-split s c)
  #"""`(ustring-split s c)` :
  Split an argument, which must produce an integer iterator, at a given character.
  The argument will most typically be a `ustring?`,
  but anything which iterates to produce integers, such as a list of integers,
  is acceptable.
  Returns a list of ustrings.
  Argument `c` must be a `string?`, `char?` or `procedure?`.
  See the procedure `string-split`, to which this should be closely analogous."""
  #;(unless (ustring? s)
    (error 'wrong-type-arg "ustring-split: requires ustring? argument, not ~s" s))
  (let ((match? (cond ((char? c)
                       (let ((ci (char->integer c)))
                         (λ (x) (= x ci))))
                      ((procedure? c) c)
                      ((string? c)
                       (let ((cl (map char->integer (string->list c))))
                         (λ (x)
                           (let l0 ((cli cl))
                             (cond ((null? cli) #f)
                                   ((= x (car cli)))
                                   (else (l0 (cdr cli))))))))))
        (i (make-iterator s)))
    ;(eprintf "(ustring-split ~s ~s)~%" s c)
    (let loop ((u (make-ustring))
               (res '()))
      (let ((i0 (i)))
        (cond ((eof-object? i0)
               (if (and (null? res) (= (ustring-length u) 0))
                   '()                  ;empty string -> '()
                   (reverse! (cons u res))))
              ((not (integer? i0))
               (error 'wrong-type-arg "ustring-split: requires an argument which produces integers, but found ~s" i0))
              ((match? i0);;((and (integer? i0) (match? i0))
               (loop (make-ustring) (cons u res)))
              (else
               (ustring-append! u i0)
               (loop u res)))))))

(define/provide (ustring-tokenize us)
  #"""`(ustring-tokenize us)` : split the ustring `us` into a list of substrings,
  where each substring is a maximal non-empty contiguous sequence of characters
  separated by whitespace.

  The ‘whitespace’ here is anything which matches `char-wordbreak?`.

  Returns a list of `ustring?`.

  The argument is typically a `ustring?`, but can be anything which has
  an iterator which produces integers."""
  (let ((included? (λ (c) (not (char-wordbreak? c))))
        (i (make-iterator us)))
    (let loop ((res '())
               (current-token (make-ustring)))
      (let ((c0 (i)))
        (cond ((eof-object? c0)
               (if (= (ustring-length current-token) 0)
                   (reverse! res)
                   (reverse! (cons current-token res))))
              ((not (integer? c0))
               (error 'wrong-type-arg "ustring-tokenize: requires an argument which produces integers, but found ~s" i0))
              ((included? c0)
               (ustring-append! current-token c0)
               (loop res current-token))
              (else
               (if (= (ustring-length current-token) 0)
                   (loop res current-token)
                   (loop (cons current-token res) (make-ustring)))))))))

(define/provide (ustring-join l sep)
  #"""`(ustring-join ustrings sep)` : join a list of ustrings,
  by connecting them with the (ustring or string) separator."""
  (if (null? l)
      (make-ustring "")
      (apply ustring-append
             (cons (car l)
                   (let loop ((strs (cdr l)))
                     (if (null? strs)
                         '()
                         `(,sep ,(car strs) . ,(loop (cdr strs)))))))))

;; Iterator which returns level-1+ braced content separately;
;; it wouldn't be unreasonable to do this using the bstring iterator,
;; ustring-iterator/bstrings,
;; but this would require some changes to the code which uses it.
#;(define/provide (ustring-iterator/braces us)
  #"""Given a ustring, return an iterator which returns the contents
  character-by-character, except that any level-0 braced content
  `{foo}` is returned as a single ustring (including the brace characters)."""
  (let ((i (make-iterator us))
        (+iterator+ #t))
    (λ ()
      (let ((i0 (i)))
        (cond ((eof-object? i0) #<eof>)
              ((= i0 #x7b)
               (let ((u (make-ustring i0)))
                 (let loop ((level 1))
                   (let ((ui0 (i)))
                     (if (eof-object? ui0)
                         (beastie-error "unexpected end-of-string reading ~s" us)
                         (begin
                           (ustring-append! u ui0)
                           (cond ((= ui0 #x7d)
                                  (if (= level 1)
                                      u
                                      (loop (- level 1))))
                                 ((= ui0 #x7b)
                                  (loop (+ level 1)))
                                 (else
                                  (loop level)))))))))
              (else i0))))))

;; Note: there is a ustring reader procedure defined in
;; readermacros.scm (qv)

(define *module-load-hook* 'unicode-load-hook*)