;; A ragbag of useful functions.  These are used throughout the code.
;;
;; More-or-less standard utilities, not present by default in s7.
;; These are pattered after SRFIs when reasonable.
;;
;; This file is part of Beastie <https://purl.org/nxg/dist/beastie>
;; SPDX-FileCopyrightText: 2024 Norman Gray <https://nxg.me.uk>
;; SPDX-License-Identifier: BSD-2-Clause

;; getopt* is an internal function, but since getopt is a macro, which
;; expands to this, we must expose it, too
(define *provides-implementation-functions*
  '(getopt* subprocess current-directory setenv symbol<?
    string->hash
    char-alnum? char-alpha? char-blank? char-cntrl? char-digit? char-graph?
    char-lower? char-print? char-punct? char-space? char-upper? char-xdigit?
    ;;char-other-letter?
    char-symbol? char-mark? char-wordbreak? char-nbsp?
    uchar-alphabetic? uchar-word-character?
    uchar-upcase uchar-downcase uchar-titlecase))

;(module 'unicode)                       ;requires unicode-encode/utf8
(define-macro (%module-verbosity-flag%) 64)

(define-macro/provide (define/trace name+args expr . exprs)
  "Like (define ...). but tracing calls to the function (for debugging)"
  `(define ,name+args
     (eprintf "trace: ~s~%" (list (#_quote ,(car name+args)) . ,(cdr name+args)))
     (let ((res (begin ,expr . ,exprs)))
       (eprintf "  -> ~s~%" res)
       res)))

(define/provide (filter pred? source)
  #"""`(filter pred? list)` : Return all the elements of list that satisfy predicate `pred?`.
  The list is not disordered -- elements that appear in the result
  list occur in the same order as they occur in the argument list.

  The input ‘list’ may also be an iterator, or something which has an implicit iterator.

  From SRFI-1."""
  ;; it's left as an exercise for the future (and an actual use-case)
  ;; to produce a filter-equivalent function which produces an iterator
  (define (filter/list pred? l)         ;from SRFI-1
    (cond ((null? l) l)
          ((pred? (car l)) (cons (car l) (filter/list pred? (cdr l))))
          (else (filter/list pred? (cdr l)))))
  (define (filter/iter pred? i)
    (let ((i0 (i)))
      (cond ((eof-object? i0) '())
            ((pred? i0) (cons i0 (filter/iter pred? i)))
            (else (filter/iter pred? i)))))
  (cond ((list? source) (filter/list pred? source))
        ((iterator? source) (filter/iter pred? source))
        (else (filter/iter pred? (make-iterator source)))))

(define/provide (fold kons knil source)
  #"""`(fold kons knil l)` : The fundamental list iterator.

  Given a list `(e1 e2 ... en)`, this evaluates to

      (kons en ... (kons e2 (kons e1 knil)) ... )

  The input ‘list’ may also be an iterator, or something which has an implicit iterator.

  From SRFI-1."""
  ;; the list case could also be handled by the fold/iter case,
  ;; but...
  (define (fold/list kons knil l)
    (if (null? l)
        knil
        (fold/list kons (kons (car l) knil) (cdr l))))
  (define (fold/iter kons knil i)
    (let ((i0 (i)))
      (if (eof-object? i0)
          knil
          (fold/iter kons (kons i0 knil) i))))
  (cond ((list? source) (fold/list kons knil source))
        ((iterator? source) (fold/iter kons knil source))
        (else
         (fold/iter kons knil (make-iterator source)))))

(define/provide (every pred? l)         ;SRFI-1 (simple case)
  #"""`(every pred? l)` : Applies the predicate across the list or iterator,
  returning true if the predicate returns true on every application
  (from SRFI-1; simple case of a single list).

  `every` applies `pred` to the first element of the list parameter. If
  this application returns false, `every` immediately returns
  false. Otherwise, it iterates, applying `pred` to the second element of
  the list, then the third, and so forth. The iteration stops when a
  false value is produced or the list runs out of values. In the latter
  case, `every` returns the true value produced by its final application
  of `pred`.

  When `l` is a list, the application of `pred` to the last element of the list
  is a tail call.; when `l` is an iterator, the function still returns the last
  application of `pred?`, but it is not a tail-call.

  If the list or iterator has no elements, every simply returns #t."""
  (define (every/list pred? l)
    (cond ((null? l) #t)
          ((= (length l) 1) (pred? (car l))) ;tail call
          ((pred? (car l)) (every/list pred? (cdr l)))
          (else #f)))
  (define (every/iterator pred? i last)
    (let ((v (i)))
      (cond ((eof-object? v) last)
            ((pred? v) => (λ (x) (every/iterator pred? i x)))
            (else #f))))
  (cond ((null? l) #t)
        ((pair? l) (every/list pred? l))
        ((iterator? l) (every/iterator pred? l #t))
        (else
         (catch 'wrong-type-arg
           (λ ()
             (every/iterator pred? (make-iterator l) #t))
           (λ _
             (error 'wrong-type-arg "every: argument must be a list, iterator or sequence, not ~s" l))))))

(define/provide (any pred? l)
  #"""`(any pred? l)` : Applies the predicate across the list,
  returning true if the predicate returns true on any application
  (from SRFI-1; simple case of a single list).

  `any` applies `pred` to the first element of the list. If this
  application returns a true value, `any` immediately returns that
  value. Otherwise, it iterates, applying `pred` to the second element of
  the list, then the third, and so forth. The iteration stops when a
  true value is produced or the list runs out of values; in the latter
  case, `any` returns `#f`.

  If `l` is a list, then the application of `pred` to the last element of
  the list is a tail call."""
  (define (any/list pred? l)
    (cond ((null? l) #f)
          ;; I interpret R5RS Sect.3.5 to indicate that
          ;; ((expr)) is not in a tail context, hence special-case the last list item
          ((= (length l) 1) (pred? (car l)))
          ((pred? (car l)))
          (else (any pred? (cdr l)))))
  (define (any/iterator pred? i)
    (let ((v (i)))
      (cond ((eof-object? v) #f)
            ((pred? v))
            (else (any/iterator pred? i)))))
  (cond ((null? l) #f)
        ((pair? l) (any/list pred? l))
        ((iterator? l) (any/iterator pred? l))
        (else
         (catch 'wrong-type-arg
           (λ ()
             (any/iterator pred? (make-iterator l)))
           (λ _
             (error 'wrong-type-arg "any: argument must be a list, iterator or sequence, not ~s" l))))))

(define/provide (take l i)                      ;SRFI-1
  "`(take l i)` :return the first `i` elements of list `l` (from SRFI-1)"
  (cond ((< i 0) (beastie-error "take: invalid count ~a" i))
        ((= i 0) '())
        ((null? l) (beastie-error "take: the count is longer than the list"))
        (else (cons (car l) (take (cdr l) (- i 1))))))

(define/provide (drop l i)                      ;SRFI-1
  "`(drop l i)` : return all but the first `i` elements of list `l` (from SRFI-1)"
  (cond ((< i 0) (beastie-error "drop: invalid count ~a" i))
        ((= i 0) l)
        ((null? l) (beastie-error "drop: the count is longer than the list"))
        (else (drop (cdr l) (- i 1)))))

(define/provide (take-right l i)                ;SRFI-1
  "`(take-right l i)` : returns the last `i` elements of list `l` (from SRFI-1)"
  (cond ((< i 0) (beastie-error "take-right: invalid count ~a" i))
        ((> i (length l))
         (beastie-error "take-right: the count is longer than the list"))
        (else
         (drop l (- (length l) i)))))

(define/provide (drop-right l i)                ;SRFI-1
  "`(drop-right l i)` : returns all but the last `i` elements of `l` (from SRFI-1)"
  (cond ((< i 0) (beastie-error "drop-right: invalid count ~a" i))
        ((> i (length l))
         (beastie-error "drop-right: the count is longer than the list"))
        (else
         (take l (- (length l) i)))))

(define/provide (split-at l idx)
  #"""`(split-at l idx)` : splits the list L at index I, returning a list of
  the first I elements, and the remaining tail, as multiple values.
  It is equivalent to

      (values (take x i) (drop x i))

  (from SRFI-1)"""
  (if (< idx 0)
      (beastie-error "split-at: invalid count ~a" idx)
      (let loop ((ll l)
                 (i idx)
                 (l1 '()))
        (cond ((= i 0) (values (reverse! l1) ll))
              ((null? ll)
               (beastie-error "split-at: error: idx=~a must be no smaller than (length l)=~a"
                              idx (length l)))
              (else (loop (cdr ll) (- i 1) (cons (car ll) l1)))))))

(define/provide (last l)
  "`(last l)` : return the last element of the non-empty, finite list L (from SRFI-1)"
  (let ((llen (length l)))
    (if (= llen 0)
        (beastie-error "last: must have a non-empty list")
        (list-ref l (- llen 1)))))
(define/provide (last-pair l)
  "`(last-pair l)` : return the last pair in the non-empty, finite list L (from SRFI-1)"
  ;; The SRFI doesn't say whether this must be the actual last-pair in the list,
  ;; or a list which is equal? to it.
  ;; I'm taking it to be the former, and depend on that
  ;; in the definition of circular-list, below.
  (if (null? l)
      (beastie-error "last-pair: must have a non-empty list")
      (let loop ((ll l))
        (if (null? (cdr ll))
            ll
            (loop (cdr ll)))))
  #;(let ((llen (length l)))
    (if (= llen 0)
        (beastie-error "last: must have a non-null list")
        (list (list-ref l (- llen 1))))))

(define/provide (flatten v)
  #"""`(flatten v)` : Flattens an arbitrary S-expression structure of
  proper lists into a single list.
  More precisely, `v` is treated as a binary tree where pairs are interior nodes,
  and the resulting list contains all of the non-null leaves of the tree in the
  same order as an in-order traversal.

  Example:

      > (flatten '((a) b (c (d) e) ()))
      '(a b c d e)
      > (flatten 'a)
      '(a)

  [specification taken from Racket, but with the added requirement that the input have
  no improper lists]."""
  ;; the Racket function from which this derives also handles improper lists
  ;; '((a) b (c (d) . e))).  I don't think I need that, and it's less elegant
  ;; to code
  (if (list? v)
      (apply append (map flatten v))
      (list v)))

(define/provide (intersperse inter l)
  #"""`(intersperse inter l)` : return a new list,
  with object `inter` between each element of the list `l`.

  Thus `(intersperse 'x '(a b c))` evaluates to `(a x b x c)`."""
  (if (null? l)
      l
      (let loop ((ll (cdr l))
                 (res (list (car l))))
        (if (null? ll)
            (reverse! res)
            (loop (cdr ll)
                  (cons (car ll) (cons inter res)))))))

(define/provide (zip l0 . rest)
  #"""`(zip l1 l2 ...) -> list` : If zip is passed _n_ lists,
  it returns a list as long as the shortest of these lists,
  each element of which is an _n_-element list comprised of
  the corresponding elements from the parameter lists.

      (zip '(one two three)
           '(1 2 3)
           '(odd even odd even odd even odd even))
          => ((one 1 odd) (two 2 even) (three 3 odd))

      (zip '(1 2 3)) => ((1) (2) (3))

  At least one of the argument lists must be finite:

      (zip '(3 1 4 1) (circular-list #f #t))
          => ((3 #f) (1 #t) (4 #f) (1 #t))

  (from SRFI-1)
  """
  (let loop ((ll (cons l0 rest))
             (res '()))
    (if (any null? ll)
        (reverse! res)
        (loop (map cdr ll)
              (cons (map car ll) res)))))

(define/provide (circular-list el0 . rest)
  #"""Constructs a circular list of the elements (from SRFI-1).

      (circular-list 'z 'q) => (z q z q z q ...)`
  """
  (let ((l (cons el0 rest)))
    (set-cdr! (last-pair l) l)))

;; as described in the s7 docs
(define-macro/provide (call-with-values producer consumer)
  #"""The standard call-with-values procedure.

  Usage: `(call-with-values (lambda () (values ...)) (lambda (a1 ...) ...))`"""
  `(,consumer (,producer)))

;; This is from SRFI-8
(define-macro/provide (receive formals producer expr . exprs)
  #"""`(receive (v ...) expr body...`) : receive multiple values [from SRFI-8].

  Example:

      (receive (v1 v2)
          (values 1 2)
        (printf "v1=~s~%" v1)
        (list v2 v1))

  prints `v1=1` and evaluates to `(2 1)`."""
  `((lambda ,formals ,expr . ,exprs) ,producer))

;; STRING-JOIN : (listof string?) string? -> string?
(define/provide* (string-join l (sep " ") (grammar 'infix))
  #"""`(string-join l [delim [grammar]])` : join the list of strings `l`,
  separated by string `delim` (default `" "`).

  The `grammar` argument is a symbol that determines how the delimiter
  is used, and defaults to `'infix`.

    * `'infix` means an infix or separator grammar: insert the
      delimiter between list elements. An empty list will produce an empty
      string.
    * `'strict-infix` means the same as `'infix`, but will raise an
      error if given an empty list.
    * `'suffix` means a suffix or terminator grammar: insert the
      delimiter after every list element.
    * `'prefix` means a prefix grammar: insert the delimiter before every list element.
  """
  (cond ((and (null? l) (eqv? grammar 'strict-infix))
         (beastie-error "string-join 'strict-infix given null list"))
        ((null? l)
         "")
        (else
         (let ((joined
                (cons (car l)
                      (let loop ((rest (cdr l)))
                        (cond ((not (null? rest))
                               (cons sep (cons (car rest) (loop (cdr rest)))))
                              ((eqv? grammar 'suffix)
                               (list sep))
                              (else '()))))))
           (apply string-append
                  (case grammar
                    ((prefix) (cons sep joined))
                    ((infix strict-infix suffix) joined)
                    (else
                     (error (sprintf "string-join: unexpected 'grammar': ~s"
                                     grammar)))))))))

;; Given a string, return a predicate that is true for any character in the string.
(define (string->pred s)
  (λ (c)
    (string-index/pred* s (λ (x) (char=? x c)) 0 (string-length s))))

(define/provide* (string-index s c (start 0) (end #f)) ; like SRFI-13
  #"""`(string-index s c [:start 0] [:end #f])` :
  Return the index of the first character in `s` which is `c`, where `c` is a procedure,
  character, or string; in the last case, the procedure returns the first
  index containing any character in the string `c` [From SRFI-13, but with
  'char-class' represented as a string].

  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 (string? s)
    (beastie-error "string-index: argument s=~s should be a string (c=~s)" s c))
  (cond ((procedure? c) (string-index/pred* s c start end))
        ((char? c) (string-index/pred* s (lambda (x) (char=? x c)) start end))
        ((string? c)                    ;use this as a char-class
         (string-index/pred* s (string->pred c) start end))
        (else (error "string-index: unexpected c: ~s" c))))

(define (string-index/pred* s c? start end)
  (let ((end-idx (or end (string-length s))))
    (let loop ((i start))
      (cond ((= i end-idx) #f)
            ((c? (string-ref s i)) i)
            (else (loop (+ i 1)))))))

(define/provide* (string-index-right s c (start 0) (end #f))
  "`(string-index-right s c [:start 0] [:end #f])` : As `string-index`, but searching leftwards from the end."
  (unless (string? s)
    (beastie-error "string-index-right: argument s=~s should be a string" s))
  (cond ((procedure? c) (string-index-right/pred* s c start end))
        ((char? c) (string-index-right/pred* s (lambda (x) (char=? x c)) start end))
        ((string? c)                    ;char-class
         (string-index-right/pred* s (string->pred c) start end))
        (else (error "string-index-right: unexpected c: ~s" c))))

(define (string-index-right/pred* s c? start end)
  (let ((end-idx (or end (- (string-length s) 1))))
    (let loop ((i end-idx))
      (cond ((< i start) #f)
            ((c? (string-ref s i)) i)
            (else (loop (- i 1)))))))

;; Split a string at a given character.
;; SRFI-13 has string-tokenize, which splits based on the char-set of
;; the items to be _included_.
;; The empty string is split to an empty list.
(define/provide (string-split s c)
  #"""`(string-split s c)` :
  Split a string at a given character.
  Argument `s` must be a `string?`.
  Argument `c` can be a character, a predicate, or a string containing split characters.
  The empty string is split to an empty list
  (This isn't in SRFI-13, which instead has `string-tokenize`,
  which splits based on the char-set of the items to be _included_).

  Repeated separator characters result in empty fields.
  That is `(string-split "a:b::c" #\:)` produces `'("a" "b" "" "c")`."""
  ;; string? char? -> (listof string?)
  (unless (string? s)
    (error 'wrong-type-arg "string-split: requres string? argument, not ~s" s))
  (if (string=? s "")
      '()
      (and s
           (let loop ((start 0))
             (let ((idx (string-index s c start)))
               (cond (idx
                      (cons (substring s start idx)
                            (loop (+ idx 1))))
                     ((= start 0)
                      (list s))
                     (else
                      (list (substring s start)))))))))

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

  This is a (still) cut-down version of the function from SRFI-13,
  restricted to whitespace, and without the start and end parameters."""
  (unless (string? s)
    (error 'wrong-type-arg "string-tokenize: requres string? argument, not ~s" s))
  (let ((included? (λ (c) (not (char-space? c))))
        (i (make-iterator s)))
    (let loop ((res '())
               (current-token '()))
      (let ((s0 (i)))
        (cond ((eof-object? s0)
               (if (null? current-token)
                   (reverse! res)
                   (reverse! (cons (list->string (reverse! current-token))
                                   res))))
              ((included? s0)
               (loop res (cons s0 current-token)))
              (else
               (if (null? current-token)
                   (loop res current-token)
                   (loop (cons (list->string (reverse! current-token))
                               res)
                         '()))))))))

(define/provide* (string-trim s (char-class #f))
  #"""`(string-trim s c)` : Trim whitespace from the start of string `s`.
  Argument `c` can be a character, a predicate, or a string containing characters to trim.
  (from SRFI-13, but currently without the start/end arguments)"""
  (let ((pred?
         (cond ((not char-class) char-space?)
               ((procedure? char-class) char-class)
               ((string? char-class) (string->pred char-class))
               ((char? char-class) (λ (c) (char=? c char-class)))
               (else (beastie-error "string-trim: bad char-class ~s" char-class))))
        (len (string-length s)))
    (cond ((= len 0) "")
          ((pred? (string-ref s 0))
           (let loop ((i 1))
             (cond ((= i len) "")
                   ((pred? (string-ref s i)) (loop (+ i 1)))
                   (else (substring s i len)))))
          (else s))))
(define/provide* (string-trim-right s (char-class #f))
  "As with `string-trim`, but trimming from the right"
  (let ((pred?
         (cond ((not char-class) char-space?)
               ((procedure? char-class) char-class)
               ((string? char-class) (string->pred char-class))
               ((char? char-class) (λ (c) (char=? c char-class)))
               (else (beastie-error "string-trim: bad char-class ~s" char-class))))
        (len (string-length s)))
    (cond ((= len 0) "")
          ((pred? (string-ref s (- len 1)))
           (let loop ((i (- len 2)))
             (cond ((< i 0) "")
                   ((pred? (string-ref s i)) (loop (- i 1)))
                   (else (substring s 0 (+ i 1))))))
          (else s))))
(define/provide* (string-trim-both s (char-class #f))
  "As with `string-trim`, but trimming from both sides"
  (string-trim (string-trim-right s char-class) char-class))

;; We could at this point define a string-normalise function, which
;; trims leading and trailing whitespace, and collapses internal
;; _horizontal_ whitespace.  That does the obvious tidying up of a
;; field, while preserving possibly significant internal paragraphing
;; (for example in an abstract).  But there's no benefit to this other
;; than tidy-mindedness, there are various tricky questions (is it OK
;; to collapse multiple spaces after a full-stop?), and the function
;; rapidly gets intricate.  So don't: string-trim-both does all that's
;; reasonably necessary.

(define/provide (string-prefix? s1 s2)
  "`(string-prefix? s1 s2)` : Is `s1` a prefix of `s2`? (SRFI-13 without optional arguments)"
  (let ((s1len (string-length s1))
        (s2len (string-length s2)))
    (and (<= s1len s2len)
         (string=? s1 (substring s2 0 s1len)))))
(define/provide (string-suffix? s1 s2)
  "`(string-suffix? s1 s2)` : Is `s1` a suffix of `s2`? (SRFI-13 without optional arguments)"
  (let ((s1len (string-length s1))
        (s2len (string-length s2)))
    (and (<= s1len s2len)
         (string=? s1 (substring s2 (- s2len s1len) s2len)))))

;; Skip this, if possible, since it's the only thing in this module
;; (which is loaded into the top-level in runtime.scm)
;; which requires the unicode module -- it seems tidier to avoid
;; loading both, since I carefully load only selected functions from
;; that module in runtime.scm
;; (define/provide (string->symbol/downcase s)
;;   #"""`(string->symbol/downcase s)` : like `string->symbol`,
;;   but downcased, and Unicode-aware.  The string can be either a scheme
;;   string, or a list of integer codepoints."""
;;   (ustring->symbol
;;    (ustring-lowercase
;;     (cond ((string? s) (unicode-decode/utf8 s))
;;           ((ustring? s) s)
;;           (else (beastie-error "string->symbol/downcase: got ~s, expected string? or ustring?" s))))))

(define/provide* (showbytes/hex s (dest #f))
  "Debugging: show the bytes in the given string."
  (let ((end (string-length s))
        (p (or dest (current-output-port))))
    (format p "~a~%" s)
    (let loop ((i 0)
               (col 0)
               (chars '()))
      (cond ((= col 16)
             (display "    |" p)
             (for-each (λ (c)
                         (if (and (char>=? c #\space) (char<=? c #\~))
                             (display c p)
                             (display "." p)))
                       (reverse! chars))
             (format p "|~%")
             (loop i 0 '()))
            ((and (= i end) (= col 0))
             (newline p) #<unspecified>)
            ((= i end)
             ;; Skip (16-col) * 3 + (0 or 2) columns.
             ;; I'm possibly misunderstanding what ~t is intended to do,
             ;; but we need to add an extra 1 to get these to line up.
             (format p "~nt" (+ (* (- 16 col) 3) (if (< col 8) 3 1)))
             (loop end 16 chars))
            (else
             (cond ((= col 0) (display "   " p))
                   ((= col 8) (display "  " p)))
             (format p " ~2,'0x" (char->integer (string-ref s i)))
             (loop (+ i 1) (+ col 1) (cons (string-ref s i) chars)))))))

(define/provide (compose-iterators* . iters)
  #"""`(compose-iterators* iter ...)` : produces an iterator which returns
  items from the given iterators, returning `#<eof>` only when all are exhausted."""
  (let ((+iterator+ #t))
    (λ ()
      (if (null? iters)
          #<eof>
          (let ((i0 ((car iters))))
            (if (eof-object? i0)
                (if (null? (set! iters (cdr iters)))
                    #<eof>
                    ((car iters)))
                i0))))))

;; standard form, implemented as suggested in s7 docs
(define-macro/provide (define-values vars expression)
  "Standard form: `(define-values (a b) (values 1 2))` defines `a` and `b` to have the given values."
  `(if (not (null? ',vars))
       (varlet (curlet) ((lambda ,vars (curlet)) ,expression))))

;; Promises, matching Racket.
;; There's nothing here which prevents against race conditions, where
;; two promises collide, nor any of the behaviour around exceptions
;; described in the Racket docs.
(define-values (make-promise* force promise?)
  (let ((*tag* 'promise))
    (define (make-promise f)
      (vector *tag* #f f))
    (define (pred? p)
      "`(promise? p)` : true if p is a promise, created by `(delay)`"
      (and (vector? p) (= (length p) 3) (eq? (vector-ref p 0) *tag*)))
    (define (force v)
      #"""`(force v)` :
      If _v_ is a promise, then the promise is forced to obtain a value.
      If the promise has not been forced before, then the result is recorded
      in the promise so that future forces on the promise produce the same value.

      If _v_ is not a promise, then it is returned as the result."""
      (cond ((not (promise? v))
             v)
            ((vector-ref v 1)           ;previously forced
             (vector-ref v 2))
            (else                       ;evaluate and cache
             (let ((newv ((vector-ref v 2))))
               (vector-set! v 2 newv)
               (vector-set! v 1 #t)
               newv))))
    (values make-promise force pred?)))
(define-macro (delay expr . exprs)
  #"""`(delay body ...)` :
  Creates a ‘promise’ that, when `force`d, evaluates the `body`s to
  produce the value of the last expression in the body.
  The result is then cached, so further uses of `force` produce the cached value immediately."""
  `(make-promise*
    (λ ()
      ,expr . ,exprs)))
(module-provide force delay make-promise* promise?)

;;;; Filesystem path, and similar, utilities
;; SRFI-170 is a set of POSIX bindings, derived from scsh, which it
;; might be useful to examine.  Unexpectedly, there is nothing there
;; about filesystem paths, so the split-path here is derived from
;; Racket.
(define/provide (split-path path)
  #"""`(split-path path)` : splits a filesystem path into components

      (split-path string?) -> (or/c string? 'relative #f)
                              (or/c string? 'up 'same)
                              boolean?

  Deconstructs path into a smaller path and an immediate directory or
  file name.  Three values are returned:

  `base` is either
    * a path,
    * `'relative` if _path_ is an immediate relative directory or filename, or
    * `#f` if _path_ is the root directory.

  `name` is either
    * a directory-name path,
    * a filename,
    * `'up` if the last part of path specifies the parent directory of
      the preceding path (e.g., .. on Unix), or
    * `'same` if the last part of path specifies the same directory as
      the preceding path (e.g., . on Unix).

  `must-be-dir?` is `#t` if `path` explicitly specifies a directory (e.g.,
  with a trailing separator), `#f` otherwise.

  This doesn't do any processing of redundant separators.
  """
  (let ((last-slash (string-index-right path #\/)))
    (cond ((not last-slash) (values 'relative path #f))
          ((= last-slash 0)
           (if (string=? path "/")         ;special case
               (values #f "/" #t)
               (values "/" (substring path 1) #f)))
          (else
           (if (= last-slash (- (string-length path) 1))
               (receive (path last ignored)
                   (split-path (substring path 0 (- (string-length path) 1)))
                 (values path last #t))
               (let ((path-cpt (substring path 0 last-slash))
                     (last-cpt (substring path (+ last-slash 1))))
                 (cond ((string=? last-cpt ".") (values path-cpt 'same #f))
                       ((string=? last-cpt "..") (values path-cpt 'up #f))
                       (else (values path-cpt last-cpt #f)))))))))

(define/provide (explode-path path)
  #"""`(explode-path path)` : split the path into a list of path components.

  If the path is absolute, then the first component in the list will be `"/"`.
  Path elements `"."` and `".."` will be replaced by symbols `same` and `up`
  respectively."""
  (let loop ((start 0)
             (components '()))
    (let* ((next-slash (string-index path #\/ start))
           (len (and next-slash (- next-slash start))))
      (cond ((not next-slash) (reverse! (cons (substring path start)
                                             components)))
            ((= len 0)
             (if (= start 0)
                 (loop (+ next-slash 1) (cons "/" components))
                 (loop (+ next-slash 1) components)))
            (else
             (let ((path-component (substring path start next-slash)))
               (cond ((and (= len 1) (string=? path-component "."))
                      (loop (+ next-slash 1) (cons 'same components)))
                     ((and (= len 2) (string=? path-component ".."))
                      (loop (+ next-slash 1) (cons 'up components)))
                     (else
                      (loop (+ next-slash 1) (cons path-component components))))))))))

(define *not-extension-re* (regexp "(.*)\\.[^./]+$"))
(define/provide (path-replace-extension path ext)
  #"""`(path-replace-extension path ext)` : Returns a path that is the
  same as `path`, except that the extension for the last element of the
  path (including the extension separator) is changed to `ext`. If the
  last element of `path` has no extension, then `ext` is added to the
  path.

  An extension is defined as a `.` that is not at the start of the path
  element followed by any number of non-`.` characters/bytes at the end of
  the path element, as long as the path element is not a directory
  indicator like ".."."""
  ;; description copied from Racket
  (let ((m (regexp-match *not-extension-re* path)))
    (if m
        (let ((base (cadr m)))
          (if (char=? (string-ref base (- (string-length base) 1)) #\/) ;ie, foo/.file
              (string-append path ext)
              (string-append base ext)))
        (string-append path ext))))

(define/provide (absolute-path? path)
  "Return `#t` if `path` is an absolute path, and `#f` otherwise."
  (and (> (string-length path) 0)
       (char=? (string-ref path 0) #\/)))
(define/provide (relative-path? path)
  "Return `#t` if `path` is an relative path, and `#f` otherwise."
  (or (= (string-length path) 0)
      (not (char=? (string-ref path 0) #\/))))

(define/provide (build-path base . rest)
  #"""`(build-path base sub ...)` : creates a path given a `base` path
  and any number of sub-path extensions. If `base` is an absolute path,
  the result is an absolute path, otherwise the result is a relative path.

  The `base` and each `sub` must be either a relative path, the symbol `'up`
  (indicating the relative parent directory), or the symbol `'same`
  (indicating the relative current directory)."""
  (string-join (map (λ (el)
                      (case el
                        ((up) "..")
                        ((same) ".")
                        (else el)))
                    (cons base rest))
               "/"))

(define/provide (path->complete-path path . opt-base)
  #"""`(path->complete-path path [base])` : turn a path into a complete path.
  If _path_ is already complete, then it is returned; if not, it is appended to _base_.
  It is an error if _base_ is not a complete path."""
  (let ((base (if (null? opt-base)
                  (current-directory)
                  (car opt-base))))
    (unless (absolute-path? base)
      (beastie-error "path->complete-path: base <~a> must be an absolute path" base))
    (if (absolute-path? path)
        path
        (string-append base "/" path))))

;;;; More nice ones

;; given a list of symbols, return a function which is such that (f s)
;; is true if 's was in the list, and #f otherwise.
;; Also (f 'add '(sym...)) adds 'sym to the set
;; and (f 'contains 'sym) is true if 'sym is in the set
;; and (f 'n 'sym) returns the number of times 'sym bas been added
;; and (f 'list proc) returns proc applied to each of (key . value), as a list
(define/provide (make-set/eqv l)
  #"""`(make-set/eqv l)` : lookup, (listof symbol?) -> (symbol? -> boolean?).
  Given a list of symbols, return a function f s.t. `(f 'x)`
  is true if `'x` was in the list.
  Also
    * `(f 'add '(sym...))` adds `'sym` to the set;
    * `(f 'contains 'sym)` is true if `'sym` is in the set
      (ie, same as `(f 'sym)`);
    * `(f 'n 'sym)` returns the number of times `'sym` bas been added;
    * `(f 'list proc)` returns `proc` applied to each of `(key . n)`, as a list."""
  (let ((*s* (apply hash-table
                    (apply append
                           (map (lambda (k) (list k 1))
                                l)))))
    (lambda (k . rest)
      (if (null? rest)
          (*s* k)
          (let ((arg (car rest)))
            (case k
              ((add) (for-each (lambda (k)
                                 (hash-table-set! *s* k (+ (or (*s* k) 0) 1)))
                               arg))
              ((contains) (*s* arg))
              ((n) (or (*s* arg) 0))
              ((list) (map arg *s*))
              (else (beastie-error 'bst "make-set/eqv: odd k=~s" k))))))))

(define-macro* (getopt spec (command-line *command-line*))
  #"""`(getopt spec [:command-line '("command" "arg" ...)` :
  Given a command-line (which defaults to `*command-line*` if the
  second argument is not present), parse it according to the option
  spec in the first argument.

  The `spec` is a list of lists with at least three elements: either
  `(#\c "docstring" expr ...)` or `(#\c arg "docstring" expr ...)`.
  This will detect an option `-c` (or `-c arg` in the second case),
  and evaluate the `expr ...`, for side-effects.

  Example:

      (getopt '((#\a "set 'a' true" (set! a-flag #t))))

  will take a `*command-line*` of `'("name" "-a" "one" "two")`, set
  `a-flag` to true, and evaluate to `'("one" "two")`.

  If there is no `-h` option, then this synthesises one from the docstrings.

  Returns the command name (the first item in `*command-line*`), an alist of
  detected options plus the return from their handler,
  and the remainder of the argument list, as multiple values."""
  (define-macro (make-handler s)
    ;(printf "make-handler: s=~s~%" `,s)
    (if (> (length `,s) 3)
        `(list ,(car s)
               #t
               (λ (,(cadr s)) ,(cadddr s)))
        `(list ,(car s)
               #f
               (λ () ,(caddr s)))))
  `(let ((getopt-spec
          (list->string
           (apply append
                  (map (λ (l)
                         ;(printf "l=~s~%" l)
                         (if (symbol? (cadr l))
                             (list (car l) #\:)
                             (list (car l))))
                       ,spec))))
         (getopt-handlers
          (map ,make-handler
               ,spec)))
     (let ((getopt-result (getopt* getopt-spec ,command-line #t)))
       (define option-results
         (filter values
                 (map (λ (opt+arg)
                                        ;(eprintf "opt+arg=~s~%" opt+arg)
                        (cond ((assv (car opt+arg) getopt-handlers)
                               => (λ (opt+handler)
                                        ;(eprintf "opt+handler=~s~%" opt+handler)
                                    (let ((f (caddr opt+handler)))
                                      (cons (car opt+arg)
                                            (if (cadr opt+handler)
                                                (f (cdr opt+arg))
                                                (f))))))

                              ((equal? opt+arg '(#\? . #\h))
                               ;; There isn't an -h option, so supply one
                               (eprintf "Options:~%")
                               (for-each (λ (l)
                                           (if (> (length l) 3)
                                               (eprintf "  -~a ~a : ~a~%" (car l) (cadr l) (caddr l))
                                               (eprintf "  -~a : ~a~%" (car l) (cadr l))))
                                         ,spec)
                               #f)
                              (else
                               ;; opt+arg is (#\? . <optionchar>)
                               (print-warning "Unexpected option -~a ignored" (cdr opt+arg))
                               #f)))
                      (car getopt-result))))
       (values (car ,command-line)
               option-results
               (cdr getopt-result)))))
(module-provide getopt)

;;;; BibTeX-related utility functions

;; Call kpsewhich on the given file.
;;
;; These could plausibly go into the bibtex.scm support, but they're
;; useful in a variety of BibTeX and TeX related functions, so it
;; seems tidy enough to put them in the general namespace.
;;
;; Cf https://www.tug.org/texinfohtml/kpathsea.html#Debugging
;; debug flag 4 is detailed, but probably the most useful
(define kpsewhich*
  (if *kpsewhich-path*
      (λ (file fmt)
        (let ((cmd+args (if (> *verbosity* *verbosity-info*)
                            (list *kpsewhich-path* "-debug" "4" "-format" fmt file)
                            (list *kpsewhich-path* "-format" fmt file))))
          (let ((result (catch 'subprocess
                          (lambda ()
                            (cond ((apply subprocess cmd+args) => string-trim-right)
                                  (else #f)))
                          (lambda args
                            ;; the kpsewhich command doesn't exist -- that's OK
                            #f))))
            (print-info "kpsewhich*: ~a ~a -> ~a" file fmt (or result "<nothing>"))
            result)))
      (λ (file fmt)
        (print-info "no kpse when looking for ~a" file)
        #f)))

;; RESOLVE-FILE : string? string? -> string?
(define* (resolve-file/plain fn (ext ".bib") (error-if-not-found? #t))
  #"""`(resolve-file/plain fn ext [:error-if-not-found? #t])` :
  Given arguments `foo` and `.ext` this returns the first of files `foo` or `foo.ext`
  that exists.

  This does respect `TEXINPUTS` for `.tex` and `.aux` files,
  `BIBINPUTS` for `.bib` files,
  and `BSTINPUTS` for `.bst` files,
  but it does not attempt to replicate all of the functionality of kpselib.

  If keyword `:error-if-not-found?` is true (the default),
  then throw a beastie-error if no file is found;
  if this is false return `#f` if a file cannot be found."""
  (unless fn
    (error 'wrong-type-arg "resolve-file/plain: argument fn must be provided and not #f"))

  (let ((result (resolve-file/plain* fn ext)))
    (cond (result
           (print-info "resolve-file/plain ~a -> ~a" fn result)
           result)
          (error-if-not-found?
           (beastie-error "can't find file ~a" fn))
          (else
           (print-info "resolve-file/plain ~a [not found]" fn)
           #f))))

(define (resolve-file/plain* fn ext)
  (if (absolute-path? fn)
      (let ((fn+ext (string-append fn ext)))
        (cond ((file-exists? fn) fn)
              ((file-exists? fn+ext) fn+ext)
              (else #f)))
      (let loop ((path
                  (cond ((string=? ext ".bib")
                         (let ((p (getenv "BIBINPUTS")))
                           (if p
                               (string-split p #\:)
                               '(""))))
                        ((string=? ext ".bst")
                         (let ((p (getenv "BSTINPUTS")))
                           (if p
                               (string-split p #\:)
                               '(""))))
                        ((or (string=? ext ".tex") (string=? ext ".aux"))
                         (let ((p (getenv "TEXINPUTS")))
                           (if p
                               (string-split p #\:)
                               '(""))))
                        (else '("")))))
        (if (null? path)
            #f
            (let* ((dir (if (string=? (car path) "")
                            (current-directory)
                            (path->complete-path (car path))))
                   (p     (build-path dir fn))
                   (p+ext (build-path dir (string-append fn ext))))
              ;; (eprintf "    ~a -> dir=~s  p=~s  p+ext=~s~%"
              ;;          fn dir p p+ext)
              (cond ((file-exists? p) p)
                    ((file-exists? p+ext) p+ext)
                    (else (loop (cdr path)))))))))

;; RESOLVE-FILE/KPSE : string? string? -> string?
;; Given a file FN, try to resolve this to a full path, using the
;; kpathsea mechanism, and trying both without and with the EXT appended.
;; Returns a full path.
(define* (resolve-file/kpse fn (ext ".bib") (error-if-not-found? #t))
  #"""`(resolve-file/kpse fn ext [:error-if-not-found? #t])` :
  Resolve a file to a full path, using `kpsewhich`.
  Given a file `fn`, try to resolve this to a full path, using the
  kpathsea mechanism, and trying both without and with the `ext` appended.

  If keyword `:error-if-not-found?` is true (the default),
  then throw a beastie-error if no file is found;
  if this is false return `#f` if no file can be found.

  Since it uses `kpsewhich`, it respects the environment variables
  `$BIBINPUTS`, etc."""

  ;; query: is this error-if-not-found? behaviour a good one?
  ;; query: should we fall back to resolve-file/plain?

  (unless fn
    (error 'wrong-type-arg "resolve-file/kpse: argument fn must be provided and not #f"))

  (or (kpsewhich* fn ext)
      (kpsewhich* (string-append fn ext) ext)
      (and error-if-not-found? (beastie-error "can't find file ~a" fn))))

(define resolve-file
  (if *kpsewhich-path*
      resolve-file/kpse
      resolve-file/plain))
(module-provide resolve-file)

;; others...
(define/provide (stringify x)
  "`(stringify x)` : Turn X into a string, one way or another."
  (cond ((string? x) x)
        ((number? x) (number->string x))
        (else (sprintf "~a" x))))

(define/provide (stringify/true x)
  #"""`(stringify/true x)` : like `(stringify x)`,
  unless `x` is `#f, when it evaluates to `#f`.
  Special-casing `#f` means this is useful alongside functions such as
  `maybe-sprintf`."""
  (and x (stringify x)))