;;; (hoot write) library
;;; Copyright (C) 2024, 2026 Igalia, S.L.
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; R7RS (scheme write) implementation, plus number->string
;;;
;;; Code:

(library (hoot write)
  (export number->string
          display write write-shared write-simple)
  (import (hoot syntax)
          (hoot cond-expand)
          (hoot errors)
          (hoot external)
          (hoot inline-wasm)
          (hoot bitwise)
          (hoot bitvectors)
          (hoot bytevectors)
          (hoot char)
          (hoot keywords)
          (hoot procedures)
          (hoot strings)
          (hoot symbols)
          (hoot numbers)
          (hoot values)
          (hoot vectors)
          (hoot ports)
          (only (hoot records)
                record? write-record)
          (hoot syntax-objects)
          (hoot syntax-transformers)
          (hoot pairs)
          (hoot eq)
          (hoot match))

  ;; A conservative upper-bound on the number of digits required to
  ;; represent a floating-point number in any supported radix.
  (define max-flonum-digits 100)
  (define digit-chars (string->utf8 "0123456789abcdefghijklmnopqrstuvwxyz"))
  (define (digit-ref d) (bytevector-u8-ref digit-chars d))
  (define zero-digit (char->integer #\0))
  (define dot-digit (char->integer #\.))
  (define minus-digit (char->integer #\-))
  (define e-digit (char->integer #\e))
  (define (digits->string bv len)
    (utf8->string bv 0 len))

  (define (reinterpret-s64 dbl)
    (cond-expand
     (hoot
      (%inline-wasm
       '(func (param $x f64) (result i64)
              (i64.reinterpret_f64 (local.get $x)))
       dbl))
     (else
      (let ((bv (make-bytevector 8)))
        (bytevector-ieee-double-native-set! bv 0 dbl)
        (bytevector-s64-native-ref bv 0)))))
  (define (not x) (if x #f #t))

  ;; This is the algorithm from Robert G. Burger and R. Kent Dybvig's
  ;; 1996 paper, "Printing floating-point numbers quickly and accurately
  ;; (https://doi.org/10.1145/231379.231397).  It does not include the
  ;; accelerated scale estimation, so there is room for improvement.  It
  ;; uses Guile's heuristics for when to print using decimal notation
  ;; and when to use scientific notation.
  ;;
  ;; At some point we should change number printing to send bytevectors
  ;; to ports instead of bouncing through strings.
  (define (flonum->utf8 dbl radix)
    (check-range radix 2 36 'flonum->utf8)

    (define (write-flonum sign f e min-e p b B)
      (define buf (make-bytevector max-flonum-digits))
      (define (put-digit! pos d)
        (bytevector-u8-set! buf pos d)
        (1+ pos))

      (define (finish-decimal pos scale sign)
        (cond
         ((<= scale 0)
          ;; All fractional part; add 0. to beginning, and any leading
          ;; zeros.
          (let ((gap (- 2 scale)))
            (bytevector-copy! buf (+ sign gap) buf sign pos)
            (let lp ((n 0))
              (when (< n gap)
                (bytevector-u8-set! buf (+ sign n) zero-digit)
                (lp (1+ n))))
            (bytevector-u8-set! buf (1+ sign) dot-digit)
            (+ pos gap)))
         ((<= pos (+ sign scale))
          ;; No fractional part; add trailing zeroes and .0.
          (let lp ((pos pos))
            (cond
             ((< pos (+ sign scale))
              (bytevector-u8-set! buf pos zero-digit)
              (lp (1+ pos)))
             (else
              (bytevector-u8-set! buf pos dot-digit)
              (bytevector-u8-set! buf (1+ pos) zero-digit)
              (+ pos 2)))))
         (else
          ;; Need to insert a dot.
          (bytevector-copy! buf (+ sign scale 1) buf (+ sign scale)
                            (1+ (- pos sign scale)))
          (bytevector-u8-set! buf (+ sign scale) dot-digit)
          (1+ pos))))
      (define (finish-scientific pos scale sign)
        (let* ((pos (finish-decimal pos 1 sign))
               (pos (put-digit! pos e-digit))
               (pos (if (<= scale 0)
                        (put-digit! pos minus-digit)
                        pos)))
          (let lp ((scale (abs (1- scale))) (pos pos))
            (if (zero? scale)
                pos
                (call-with-values (lambda () (truncate/ scale 10))
                  (lambda (q r)
                    (put-digit! (lp q pos) (digit-ref r))))))))
      (define (finish pos scale sign)
        (define len
          (if (or (<= scale -3) (and (<= 8 scale) (< 3 (- scale pos sign))))
              (finish-scientific pos scale sign)
              (finish-decimal pos scale sign)))
        (bytevector-copy buf 0 len))

      (define even? (zero? (logand f 1)))

      (define (scale pos r s m+ m- k B)
        (cond
         (((if even? >= >) (+ r m+) s)  ; k is too low
          (scale pos r (* s B) m+ m- (+ k 1) B))
         (((if even? < <=) (* (+ r m+) B) s) ; k is too high
          (scale pos (* r B) s (* m+ B) (* m- B) (- k 1) B))
         (else                          ; k is correct
          (finish (generate pos r s m+ m- B) k sign))))

      (define (generate pos r s m+ m- B)
        (call-with-values (lambda () (truncate/ (* r B) s))
          (lambda (d r)
            (let* ((m+ (* m+ B))
                   (m- (* m- B))
                   (tc1 ((if even? <= <) r m-))
                   (tc2 ((if even? >= >) (+ r m+) s)))
              (if (not tc1)
                  (if (not tc2)
                      (generate (put-digit! pos (digit-ref d))
                                r s m+ m- B)
                      (put-digit! pos (digit-ref (+ d 1))))
                  (put-digit! pos
                              (digit-ref
                               (if (not tc2)
                                   d
                                   (if (< (* r 2) s)
                                       d
                                       (+ d 1))))))))))

      (let ((pos (if (zero? sign) 0 (put-digit! 0 minus-digit))))
        (if (>= e 0)
            (if (not (= f (ash 1 (- p 1))))
                (let ((be (ash 1 e)))
                  (scale pos (* f be 2) 2 be be 0 B))
                (let* ((be (ash 1 e))
                       (be1 (* be b)))
                  (scale pos (* f be 2) (* b 2) be1 be 0 B)))
            (if (or (= e min-e) (not (= f (ash 1 (- p 1)))))
                (scale pos (* f 2) (* (ash 1 (- e)) 2) 1 1 0 B)
                (scale pos (* f b 2) (* (ash 1 (- 1 e)) 2) b 1 0 B)))))

    (define s64 (reinterpret-s64 dbl))
    (define sign (logand 1 (ash s64 -63)))
    (define exponent (logand (1- (ash 1 11)) (ash s64 -52)))
    (define mantissa (logand (1- (ash 1 52)) s64))
    (define min-exponent -1074)
    (define exponent-bias (1- min-exponent))
    (cond
     ((= exponent 2047)
      (if (= 0 mantissa)
          (if (zero? sign)
              (string->utf8 "+inf.0")
              (string->utf8 "-inf.0"))
          (string->utf8 "+nan.0")))
     ((= exponent 0)
      (if (= 0 mantissa)
          (if (zero? sign)
              (string->utf8 "0.0")
              (string->utf8 "-0.0"))
          ;; Denormal.
          (write-flonum sign mantissa min-exponent min-exponent 53 2 10)))
     (else
      (let ((exponent (+ exponent exponent-bias))
            (mantissa (logior (ash 1 52) mantissa)))
        (write-flonum sign mantissa exponent min-exponent 53 2 10)))))

  (define (flonum->string n radix)
    (utf8->string (flonum->utf8 n radix)))

  (define* (number->string n #:optional (radix 10))
    (cond
     ((exact-integer? n)
      (if (zero? n)
          "0"
          (let* ((mag (if (< n 0) (- n) n))
                 (digits
                  (case radix
                    ((2) (let lp ((mag mag) (out '()))
                           (if (zero? mag)
                               out
                               (lp (ash mag -1)
                                   (cons (integer->char
                                          (+ (char->integer #\0)
                                             (logand mag 1)))
                                         out)))))
                    ((8) (let lp ((mag mag) (out '()))
                           (if (zero? mag)
                               out
                               (lp (ash mag -3)
                                   (cons (integer->char
                                          (+ (char->integer #\0)
                                             (logand mag 7)))
                                         out)))))
                    ((10) (let lp ((mag mag) (out '()))
                            (if (zero? mag)
                                out
                                (lp (quotient mag 10)
                                    (cons (integer->char
                                           (+ (char->integer #\0)
                                              (remainder mag 10)))
                                          out)))))
                    ((16) (let lp ((mag mag) (out '()))
                            (if (zero? mag)
                                out
                                (lp (ash mag -4)
                                    (cons (integer->char
                                           (let ((digit (logand mag 15)))
                                             (+ (if (< digit 10)
                                                    (char->integer #\0)
                                                    (- (char->integer #\a) 10))
                                                digit)))
                                          out))))))))
            (list->string (if (negative? n) (cons #\- digits) digits)))))
     ((exact? n)
      (string-append (number->string (numerator n) radix)
                     "/"
                     (number->string (denominator n) radix)))
     ((real? n)
      (utf8->string (flonum->utf8 n radix)))
     (else
      (string-append (number->string (real-part n) radix)
                     "/"
                     (number->string (imag-part n) radix)
                     "i"))))

  (define* (%write-datum port x #:optional quote-strings?)
    (define (recur x) (%write-datum port x quote-strings?))
    (cond
     ((eq? x #f)         (write-string "#f" port))
     ((eq? x #t)         (write-string "#t" port))
     ((eq? x #nil)       (write-string "#nil" port))
     ((eq? x '())        (write-string "()" port))
     ((eq? x (if #f #f)) (write-string "#<unspecified>" port))
     ((eof-object? x)    (write-string "#<eof>" port))
     ((number? x)        (write-string (number->string x) port))
     ((char? x)
      (if quote-strings?
          (case x
            ((#\alarm)     (write-string "#\\alarm" port))
            ((#\backspace) (write-string "#\\backspace" port))
            ((#\delete)    (write-string "#\\delete" port))
            ((#\escape)    (write-string "#\\escape" port))
            ((#\newline)   (write-string "#\\newline" port))
            ((#\null)      (write-string "#\\null" port))
            ((#\return)    (write-string "#\\return" port))
            ((#\space)     (write-string "#\\space" port))
            ((#\tab)       (write-string "#\\tab" port))
            ((#\a #\b #\c #\d #\e #\f #\g #\h #\i #\j #\k #\l #\m
              #\n #\o #\p #\q #\r #\s #\t #\u #\v #\w #\x #\y #\z
              #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J #\K #\L #\M
              #\N #\O #\P #\Q #\R #\S #\T #\U #\V #\W #\X #\Y #\Z
              #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9
              #\` #\~ #\! #\@ #\# #\$ #\% #\^ #\& #\* #\( #\) #\- #\_ #\= #\+
              #\[ #\] #\{ #\} #\\ #\| #\; #\: #\' #\" #\< #\> #\, #\. #\/ #\?)
             (write-char #\# port)
             (write-char #\\ port)
             (write-char x port))
            (else
             (write-char #\# port)
             (write-char #\\ port)
             (write-char #\x port)
             (write-string (number->string (char->integer x) 16) port)))
          (write-char x port)))
     ((pair? x)
      (write-char #\( port)
      (recur (car x))
      (let lp ((tail (cdr x)))
        (cond
         ((null? tail)
          (write-char #\) port))
         ((pair? tail)
          (write-char #\space port)
          (recur (car tail))
          (lp (cdr tail)))
         (else
          (write-string " . " port)
          (recur tail)
          (write-char #\) port)))))
     ((string? x)
      (cond
       (quote-strings?
        (write-char #\" port)
        (string-for-each (lambda (ch)
                           (case ch
                             ((#\newline)
                              (write-char #\\ port)
                              (write-char #\n port))
                             ((#\\ #\")
                              (write-char #\\ port)
                              (write-char ch port))
                             (else
                              (write-char ch port))))
                         x)
        (write-char #\" port))
       (else
        (write-string x port))))
     ((symbol? x)
      (%write-datum port (symbol->string x) #f))
     ((vector? x)
      (write-char #\# port)
      (recur (vector->list x)))
     ((bytevector? x)
      (write-string "#vu8(" port)
      (let lp ((i 0))
        (when (< i (bytevector-length x))
          (unless (zero? i)
            (write-char #\space port))
          (write-string (number->string (bytevector-u8-ref x i)) port)
          (lp (1+ i))))
      (write-char #\) port))
     ((bitvector? x)
      (write-string "#*" port)
      (let lp ((i 0))
        (when (< i (bitvector-length x))
          (write-char (if (bitvector-ref x i) #\1 #\0) port)
          (lp (1+ i)))))
     ;; Test for records before procedures because applicable records
     ;; are considered procedures.
     ((record? x)
      (write-record x port write))
     ((procedure? x)
      (match (procedure-name x)
        (#f
         (write-string "#<procedure>" port))
        (name
         (write-string "#<procedure " port)
         (write name port)
         (write-char #\> port))))
     ((keyword? x)
      (write-string "#:" port)
      (write-string (symbol->string (keyword->symbol x)) port))
     ((port? x)
      (write-string "#<port>" port))
     ((syntax? x)
      (write-string "#<syntax" port)
      (let ((expr (syntax-expression x))
            (src (syntax-sourcev x)))
        (when src
          (let ((file (vector-ref src 0))
                (line (1+ (vector-ref src 1)))
                (col (vector-ref src 2)))
            (write-char #\: port)
            (write-string (or file "unknown file") port)
            (write-char #\: port)
            (write-string (number->string line) port)
            (write-char #\: port)
            (write-string (number->string col) port)))
        (write-char #\space port)
        (write expr port)
        (write-char #\> port)))
     ((syntax-transformer? x)
      (write-string "#<syntax-transformer " port)
      (write (syntax-transformer-type x) port)
      (write-char #\space port)
      (write (syntax-transformer-value x) port)
      (write-char #\> port))
     ((external? x)
      (write-string "#<external null?: " port)
      (write (external-null? x) port)
      (write-char #\> port))
     (else
      (recur "unhandled object :("))))

  (define* (display datum #:optional (port (current-output-port)))
    (%write-datum port datum #f))
  (define* (write datum #:optional (port (current-output-port)))
    (%write-datum port datum #t))

  (define* (write-shared datum #:optional (port (current-output-port)))
    (raise (make-unimplemented-error 'write-shared)))
  (define* (write-simple datum #:optional (port (current-output-port)))
    (write datum port))
  )
