;; SPDX-FileCopyrightText: 2026 Artyom Bologov
;; SPDX-License-Identifier: MIT

;;; Permission is hereby granted, free of charge, to any person
;;; obtaining a copy of this software and associated documentation
;;; files (the "Software"), to deal in the Software without
;;; restriction, including without limitation the rights to use,
;;; copy, modify, merge, publish, distribute, sublicense, and/or
;;; sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following
;;; conditions:
;;;
;;; The above copyright notice and this permission notice shall be
;;; included in all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;; OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;; OTHER DEALINGS IN THE SOFTWARE.

(define-syntax when/null
  (syntax-rules ()
    ((_ cond body ...)
     (if cond
         (begin body ...)
         (list)))))

(define (assoc-ref key list)
  (if (assoc key list)
      (cadr (assoc key list))
      #f))

(define ? display)

;; This is an escape hatch for Guile outlawing passing dotted lists to
;; length+.
(define (length++ lst)
  (if (dotted-list? lst)
      (let loop ((lst lst))
        (if (not (pair? lst))
            0
            (+ 1 (loop lst))))
      (length+ lst)))

(define (take-5 lst)
  (take lst (min (length++ lst) 5)))

(define (take-10 lst)
  (take lst (min (length++ lst) 10)))

(define (print-abridged object)
  (if (> (length object) 5)
      (begin (? "(")
             (map (lambda (e)
                    (? e) (? " "))
                  (take-5 object))
             (when (> (length object) 5)
               (? "[...and ") (? (- (length object) 5)) (? " more]"))
             (? ")"))
      (? object)))

(define (to-string-with object proc)
  (call-with-port (open-output-string)
    (lambda (p)
      (proc object p)
      (get-output-string p))))

;;; inspect-properties

(define (object-properties object)
  `((id ,(object-address object))
    (location ,(object-address object))
    ,@(when/null (record? object)
                 `((type ,(record-type-name (record-rtd object)))))
    (write ,(to-string-with object write))
    (display ,(to-string-with object display))))

(define (number-properties object)
  `((real-part ,(real-part object))
    (imag-part ,(imag-part object))
    (numerator ,(numerator object))
    (denominator ,(denominator object))
    ,@(when/null (rational? object)
                 `((real-sign ,(cond
                                ((negative? object) -1)
                                ((zero? object) 0)
                                ((positive? object) 1)))))
    (real-base 2)
    ;; Working under an assumption that Guile floats are C doubles
    ;; https://stackoverflow.com/questions/9999221/double-precision-decimal-places
    (real-precision 15)
    (real-mantissa-length 53)
    (real-exponent-length 10)
    (fixnum-most-positive most-positive-fixnum)
    (fixnum-most-negative most-negative-fixnum)
    ;; Working under an assumption that Guile floats are C doubles
    (flonum-least-positive 2.225e-307)
    (flonum-least-negative -2.225e-307)
    (flonum-most-positive 179769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368.000000)
    (flonum-most-negative -179769313486231570814527423731704356798070567525844996598917476803157260780028538760589558632766878171540458953514382464234321326889464182768467546703537516986049910576551282076245490090389328944075868508455133942304583236903222948165808559332123348274797826204144723168738177180919299881250404026184124858368.000000)
    ,@(when/null (integer? object)
                 `((integer-length ,(integer-length object))))
    ,@(when/null (and (integer? object)
                      (<= object #x10FFFF))
                 `((integer->char ,(integer->char object))))
    ;; integer-object seems to be generally impossible:
    ;; https://github.com/ashinn/chibi-scheme/issues/1136
    (display-2 ,(number->string object 2))
    (display-8 ,(number->string object 8))
    (display-16 ,(number->string object 16))))

;; Commented out until it’s clear what SCM_BOOL_T and SCM_BOOL_F are
;; (define (boolean-properties object)
;;   `((boolean->integer ,(if object 1 0))))

(define (pair-properties object)
  (let* ((truly-last (if (circular-list? object)
                         '()
                         (let loop ((object object))
                           (if (pair? object)
                               (loop (cdr object))
                               object)))))
    `((car ,(car object))
      (cdr ,(cdr object))
      ,@(when/null (and (proper-list? object)
                        (not (circular-list? object)))
                   `((last ,(last object))
                     (last-pair ,(last-pair object))
                     (length ,(length object))))
      ,@(when/null (not (dotted-list? object))
                   `((length+ ,(length++ object))
                     ;; Elements of the list, except the dotted tail
                     ,@(let loop ((length (length++ object))
                                  (idx 0)
                                  (object object))
                         (if (or (eq? #f length)
                                 (zero? length))
                             '()
                             (cons (list idx (car object))
                                   (loop (- length 1)
                                         (+ idx 1)
                                         (cdr object)))))))
      ,@(when/null (dotted-list? object)
                   `((dotted-last ,truly-last)))
      ,@(when/null (not (or (circular-list? object)
                            (dotted-list? object)))
                   `((list->vector ,(list->vector object))))
      ,@(when/null (and (not (or (circular-list? object)
                                 (dotted-list? object)))
                        (every char? object))
                   `((list->string ,(list->string object)))))))

(define (symbol-properties object)
  `((symbol->string ,(symbol->string object))
    ;; That’s crude and likely quite broken, but whatever
    ,@(call/cc
       (lambda (k)
         (with-exception-handler
             (lambda (e)
               (k '()))
           (lambda _
             `((symbol-value ,(eval object (interaction-environment))))))))
    (symbol-library ,(find-module (symbol-module object)))))

(define (char-properties object)
  `((char->integer ,(char->integer object))
    ,@(when/null (char-general-category object)
                 `((char-category ,(char-general-category object))))
    ;; Unicode limit, untested
    (char-limit #x10FFFF)
    (char-alphabetic? ,(char-alphabetic? object))
    (char-numeric? ,(char-numeric? object))
    (char-whitespace? ,(char-whitespace? object))
    (char-lower-case? ,(char-lower-case? object))
    (char-upper-case? ,(char-upper-case? object))))

(define (string-properties object)
  `((string->symbol ,(string->symbol object))
    (string->list ,(string->list object))
    (string->vector ,(string->vector object))
    (string->utf8 ,(string->utf8 object))
    (string->number ,(string->number object))
    (string-length ,(string-length object))
    (string-byte-length
     ,(bytevector-length (string->utf8 object)))
    (file-exists? ,(file-exists? object))
    ,@(map (cut list <> <>)
           (iota (string-length object))
           (string->list object))))

(define (vector-properties object)
  `((vector-length ,(vector-length object))
    (vector->list ,(vector->list object))
    ,@(when/null (every char? (vector->list object))
                 `((vector->string ,(vector->string object))))
    ,@(map (cut list <> <>)
           (iota (vector-length object))
           (vector->list object))))

(define (bytevector-properties object)
  `(,@(when/null (false-if-exception (utf8->string object))
                 `((utf8->string ,(utf8->string object))))
    ,@(let loop ((idx 0))
        (if (>= idx (bytevector-length object))
            '()
            (cons (list idx (bytevector-u8-ref object idx))
                  (loop (+ 1 idx)))))))

(define (port-properties object)
  `((port-open? ,(if (input-port? object)
                     (input-port-open? object)
                     (output-port-open? object)))
    (port-direction ,(cond
                      ((and (input-port? object)
                            (output-port? object))
                       'both)
                      ((input-port? object)
                       'input)
                      ((output-port? object)
                       'output)))
    (port-type ,(if (textual-port? object)
                    'textual
                    'binary))
    ,@(when/null (port-filename object)
                 `((port-file ,(port-filename object))
                   (port-file-descriptor ,(port->fdes object))))
    (port-line ,(port-line object))
    (port-column ,(port-column object))
    ,@(when/null (and (output-port? object)
                      (false-if-exception (get-output-string object)))
                 `((get-output-string ,(get-output-string object))))
    ,@(when/null (and (output-port? object)
                      (false-if-exception (get-output-bytevector object)))
                 `((get-output-bytevector ,(get-output-bytevector object))))))

(define (procedure-arity-191 object)
  (match (procedure-arguments object)
    ;; TODO: handle keyword args too
    ((('required . required)
      ('optional . optional)
      ('keyword . keyword)
      ('allow-other-keys? . allow-other-keys?)
      ('rest . rest?))
     (let ((arity (length required)))
       (- (* (if rest? -1 1)
             (+ (if (zero? arity)
                    1
                    (expt 2 arity))
                (fold (lambda (val acc)
                        (+ acc (expt 2 val)))
                      0
                      (iota (length optional) (+ 1 (length required))))))
          (if rest? 1 0))))
    (_ -1)))

(define (procedure-arglists object)
  (match (procedure-arguments object)
    ;; TODO: handle keyword args too
    ((('required . required)
      ('optional . optional)
      ('keyword . keyword)
      ('allow-other-keys? . allow-other-keys?)
      ('rest . rest?))
     (let loop ((required required)
                (optional optional))
       (cond
        ((and (null? optional)
              rest?)
         `((,@required . _)))
        ((null? optional)
         `((,@required)))
        (else
         (cons `(,@required ,@optional)
               (loop required (cdr optional)))))))
    (_ '())))

(define (procedure-properties object)
  `((procedure-name ,(procedure-name object))
    (procedure-arity-mask ,(procedure-arity-191 object))
    #;(procedure-arity ,(procedure-arity-102 object))
    ;; TODO: Argument types. Maybe when SRFI 253/273 is merged?
    ,@(when/null (positive? (length (procedure-arglists object)))
                 `((procedure-arglists ,(procedure-arglists object))))))

(define (record-properties object)
  (let ((rtd (record-rtd object)))
    `((record-type ,rtd)
      ,@(let ((slots (record-type-fields rtd)))
          (map (lambda (name idx)
                 (list name ((record-accessor rtd idx) object)))
               slots
               (iota (length slots)))))))

(define (rtd-properties object)
  `((rtd-name ,(record-type-name object))
    (rtd-field-names ,(record-type-fields object))
    (rtd-constructor ,(procedure-name (record-type-constructor object)))
    (rtd-vtable ,record-type-vtable)))

(define (error-object-properties object)
  `((error-object-message ,(error-object-message object))
    (error-object-irritants ,(error-object-irritants object))))

(define (exception-properties object)
  `((exception-kind ,(exception-kind object))
    (exception-args ,(exception-args object))))

(define (hash-properties object)
  `((hash-table-equivalence-function
     ,(procedure-name (hash-table-equivalence-function object)))
    (hash-table-hash-function
     ,(procedure-name (hash-table-hash-function object)))
    (hash-table-size ,(hash-table-size object))
    ,@(map (lambda (entry)
             (list (car entry) (cdr entry)))
           (hash-table->alist object))))

(define (numeric-vector-properties object)
  (let ((build (lambda (tag length-proc length-proc-name list-proc ref-proc)
                 `((vector-tag ,tag)
                   (,length-proc-name ,(length-proc object))
                   (,(procedure-name list-proc) ,(list-proc object))
                   ,@(map (lambda (idx)
                            (list idx (ref-proc object idx)))
                          (iota (length-proc object)))))))
    (cond
     ((s8vector? object)
      (build 's8 s8vector-length 's8vector-length s8vector->list s8vector-ref))
     ((u8vector? object)
      (build 'u8 u8vector-length 'u8vector-length u8vector->list u8vector-ref))
     ((s16vector? object)
      (build 's16 s16vector-length 's16vector-length s16vector->list s16vector-ref))
     ((u16vector? object)
      (build 'u16 u16vector-length 'u16vector-length u16vector->list u16vector-ref))
     ((s32vector? object)
      (build 's32 s32vector-length 's32vector-length s32vector->list s32vector-ref))
     ((u32vector? object)
      (build 'u32 u32vector-length 'u32vector-length u32vector->list u32vector-ref))
     ((s64vector? object)
      (build 's64 s64vector-length 's64vector-length s64vector->list s64vector-ref))
     ((u64vector? object)
      (build 'u64 u64vector-length 'u64vector-length u64vector->list u64vector-ref))
     ((f32vector? object)
      (build 'f32 f32vector-length 'f32vector-length f32vector->list f32vector-ref))
     ((f64vector? object)
      (build 'f64 f64vector-length 'f64vector-length f64vector->list f64vector-ref)))))

(define (char-set-properties object)
  `((char-set-size ,(char-set-size object))
    (char-set->list ,(char-set->list object))
    (char-set->string ,(char-set->string object))
    (char-set-name ,(cond
                     ((eq? char-set:lower-case object)
                      'char-set:lower-case)
                     ((eq? object char-set:upper-case)
                      'char-set:upper-case)
                     ((eq? object char-set:title-case)
                      'char-set:title-case)
                     ((eq? object char-set:letter)
                      'char-set:letter)
                     ((eq? object char-set:digit)
                      'char-set:digit)
                     ((eq? object char-set:letter+digit)
                      'char-set:letter+digit)
                     ((eq? object char-set:graphic)
                      'char-set:graphic)
                     ((eq? object char-set:printing)
                      'char-set:printing)
                     ((eq? object char-set:whitespace)
                      'char-set:whitespace)
                     ((eq? object char-set:iso-control)
                      'char-set:iso-control)
                     ((eq? object char-set:punctuation)
                      'char-set:punctuation)
                     ((eq? object char-set:symbol)
                      'char-set:symbol)
                     ((eq? object char-set:hex-digit)
                      'char-set:hex-digit)
                     ((eq? object char-set:blank)
                      'char-set:blank)
                     ((eq? object char-set:ascii)
                      'char-set:ascii)
                     ((eq? object char-set:empty)
                      'char-set:empty)
                     ((eq? object char-set:full)
                      'char-set:full)))
    ,@(map (lambda (char) (list char char))
           (char-set->list object))))

(define (inspect-properties object)
  (append (object-properties object)
          ((cond
            ((number? object) number-properties)
            ((pair? object) pair-properties)
            ((symbol? object) symbol-properties)
            ((char? object) char-properties)
            ((string? object) string-properties)
            ((vector? object) vector-properties)
            ((bytevector? object) bytevector-properties)
            ((port? object) port-properties)
            ((procedure? object) procedure-properties)
            ((record-type? object) rtd-properties)
            ((error-object? object) error-object-properties)
            ((exception? object) exception-properties)
            ((hash-table? object) hash-properties)
            ((s8vector? object) numeric-vector-properties)
            ((u8vector? object) numeric-vector-properties)
            ((s16vector? object) numeric-vector-properties)
            ((u16vector? object) numeric-vector-properties)
            ((s32vector? object) numeric-vector-properties)
            ((u32vector? object) numeric-vector-properties)
            ((s64vector? object) numeric-vector-properties)
            ((u64vector? object) numeric-vector-properties)
            ((f32vector? object) numeric-vector-properties)
            ((f64vector? object) numeric-vector-properties)
            ((char-set? object) char-set-properties)
            (else record-properties))
           object)))

;;; inspect-describe

(define (number-describe object)
  (let ((props (number-properties object)))
    (cond
     ((rational? object)
      (? "Number ")
      (? object)
      (and-let* ((len (assoc-ref 'integer-length props)))
        (? " (") (? len) (? " bits)"))
      (? " #b") (? (assoc-ref 'display-2 props))
      (? " #o") (? (assoc-ref 'display-8 props))
      (? " #x") (? (assoc-ref 'display-16 props))
      (when (<= 0 object 1)
        (? " ") (? (* object 100)) (? "%")))
     (else (? "Number ") (? object)))))

(define (pair-describe object)
  (let ((props (pair-properties object)))
    (? "Pair ")
    (if (circular-list? object)
        (write object)
        (let ((first-five (take-5 object)))
          (? "(")
          (? (car first-five))
          (map (lambda (elem)
                 (? " ")
                 (? elem))
               (cdr first-five))
          (when (> (length++ object) 5)
            (? " [...and ") (? (- (length++ object) 5)) (? " more]"))
          (and-let* ((dl (assoc-ref 'dotted-last props)))
            (? " . ")
            (? dl))
          (? ")")))))

(define (symbol-describe object)
  (let ((props (symbol-properties object)))
    (? "Symbol ") (? object)
    (and-let* ((val (assoc-ref 'symbol-value props)))
      (? " = ") (? val))))

(define (char-describe object)
  (let ((props (char-properties object)))
    (? "Char ") (write object)
    (? " U+") (? (string-upcase (number->string (char->integer object))))
    (and-let* ((category (assoc-ref 'char-category props)))
      (? "[") (? category) (? "]"))))

(define (string-describe object)
  (let ((props (string-properties object)))
    (? "String \"") (map ? (take-10 (string->list object)))
    (when (> (string-length object) 10)
      (? "[...and ") (? (- (string-length object) 10)) (? " more]"))
    (? "\"")
    (and-let* ((len (assoc-ref 'string-byte-length props)))
      (? " (") (? len) (? " bytes)"))))

(define (vector-describe object)
  (let ((props (vector-properties object)))
    (? "Vector #")
    (print-abridged (vector->list object))
    (when (assoc-ref 'vector->string props)
      (? " (") (write (assoc-ref 'vector->string props)) (? ")"))))

(define (bytevector->list object)
  (let loop ((idx 0))
    (if (>= idx (bytevector-length object))
        '()
        (cons (bytevector-u8-ref object idx) (loop (+ 1 idx))))))

(define (bytevector-describe object)
  (let ((props (bytevector-properties object)))
    (? "Bytevector #u8")
    (print-abridged (bytevector->list object))
    (when (assoc-ref 'utf8->string props)
      (? " (") (write (assoc-ref 'utf8->string props)) (? ")"))))

(define (procedure-describe object)
  (let ((props (procedure-properties object)))
    (begin (? "Procedure ")
           (? (or (assoc-ref 'procedure-name props)
                  "λ"))
           (and-let* ((arglists (assoc-ref 'procedure-arglists props)))
             (? " ")
             (? (fold-right (lambda (arglist acc)
                              (cons* arglist (string->symbol "|") acc))
                            (car arglists)
                            (cdr arglists))))
           (when (or (assoc-ref 'procedure-argument-types props)
                     (assoc-ref 'procedure-return-types props))
             (newline)
             (? (assoc-ref 'procedure-argument-types props))
             (? " → ")
             (? (assoc-ref 'procedure-return-types props))))))

(define (error-object-describe object)
  (begin (? "Error object ")
         (write (error-object-message object))
         (? " ")
         (? (error-object-irritants object))))

(define (exception-describe object)
  (begin (? "Exception ")
         (write (exception-kind object))
         (? " ")
         (? (exception-args object))))

(define (hash-describe object)
  (let ((props (hash-properties object)))
    (? "Hash table [")
    (? (assoc-ref 'hash-table-equivalence-function props))
    (? ", ")
    (? (assoc-ref 'hash-table-size props))
    (? "]\n")
    (map (lambda (pair)
           (? "  ") (? pair) (newline))
         (take-5 (hash-table->alist object)))))

(define (port-describe object)
  (let ((props (port-properties object)))
    (if (assoc-ref 'port-open? props)
        (? "Open ")
        (? "Closed "))
    (case (assoc-ref 'port-direction props)
      ((input) (? "Input "))
      ((output) (? "Output "))
      ((both) (? "Bidirectional ")))
    (? "port ")
    (? object)))

(define (numeric-vector-describe object)
  (let ((describe (lambda (tag length-proc length-proc-name list-proc ref-proc)
                    (? (string-upcase (symbol->string tag)))
                    (? " Vector [")
                    (? (length-proc object))
                    (? "] ")
                    (? "#")
                    (? tag)
                    (print-abridged (list-proc object)))))
    (cond
     ((s8vector? object)
      (describe 's8 s8vector-length 's8vector-length s8vector->list s8vector-ref))
     ((u8vector? object)
      (describe 'u8 u8vector-length 'u8vector-length u8vector->list u8vector-ref))
     ((s16vector? object)
      (describe 's16 s16vector-length 's16vector-length s16vector->list s16vector-ref))
     ((u16vector? object)
      (describe 'u16 u16vector-length 'u16vector-length u16vector->list u16vector-ref))
     ((s32vector? object)
      (describe 's32 s32vector-length 's32vector-length s32vector->list s32vector-ref))
     ((u32vector? object)
      (describe 'u32 u32vector-length 'u32vector-length u32vector->list u32vector-ref))
     ((s64vector? object)
      (describe 's64 s64vector-length 's64vector-length s64vector->list s64vector-ref))
     ((u64vector? object)
      (describe 'u64 u64vector-length 'u64vector-length u64vector->list u64vector-ref))
     ((f32vector? object)
      (describe 'f32 f32vector-length 'f32vector-length f32vector->list f32vector-ref))
     ((f64vector? object)
      (describe 'f64 f64vector-length 'f64vector-length f64vector->list f64vector-ref)))))

(define (char-set-describe object)
  (let ((props (char-set-properties object)))
    (? "Char set ")
    (when (assoc-ref 'char-set-name props)
      (? (assoc-ref 'char-set-name props))
      (? " "))
    (? "{")
    (? (list->string (take-10 (char-set->list object))))
    (when (> (char-set-size object) 10)
      (? "..."))
    (? "}")))

(define (record-describe object)
  (let ((props (record-properties object)))
    (? "Record ")
    (? (assoc-ref 'record-type props))
    (? " ")
    (? object)
    (newline)
    (map (lambda (prop)
           (? "  ")
           (? (car prop))
           (? ": ")
           (? (cadr prop))
           (newline))
         (cdr props))))

(define inspect-describe
  (case-lambda
   ((object) (inspect-describe object (current-output-port)))
   ((object (port port?))
    (parameterize ((current-output-port port))
      ((cond
        ((number? object) number-describe)
        ((boolean? object) boolean-describe)
        ((pair? object) pair-describe)
        ((symbol? object) symbol-describe)
        ((char? object) char-describe)
        ((string? object) string-describe)
        ((vector? object) vector-describe)
        ((bytevector? object) bytevector-describe)
        ((port? object) port-describe)
        ((procedure? object) procedure-describe)
        ((type? object) type-describe)
        ((error-object? object) error-object-describe)
        ((exception? object) exception-describe)
        ((hash-table? object) hash-describe)
        ((s8vector? object) numeric-vector-describe)
        ((u8vector? object) numeric-vector-describe)
        ((s16vector? object) numeric-vector-describe)
        ((u16vector? object) numeric-vector-describe)
        ((s32vector? object) numeric-vector-describe)
        ((u32vector? object) numeric-vector-describe)
        ((s64vector? object) numeric-vector-describe)
        ((u64vector? object) numeric-vector-describe)
        ((f32vector? object) numeric-vector-describe)
        ((f64vector? object) numeric-vector-describe)
        ((char-set? object) char-set-describe)
        (else record-describe))
       object)))))

