; SPDX-FileCopyrightText: 2026 Sergei Egorov
;
; SPDX-License-Identifier: MIT

; Fancy Pretty Printing library

(define-library (srfi 272 fancy)
  (import (scheme base) (scheme char) (scheme cxr)
    (scheme case-lambda) (scheme inexact) (scheme file)
    (scheme read) (scheme write))
  
  ; main machinery
  (import
    (rename (srfi 272 advanced)
      (pprint-file advanced-pprint-file)))
  ; color support
  (import (srfi 272 colorize))
  
  ; procedures
  (export pp pp* pprint pprint-shared pprint-simple pprint-file
    pprint-file/html pretty-style pretty-hook)
  
  ; parameters
  (export pp-width pp-circle pp-graph pp-radix pp-length
    pp-level pp-lines pp-indent pp-tab pp-max-tab pp-miser-width
    pp-inline-width pp-brackets pp-code pp-pretty pp-newline
    pp-color pp-emit pp-decorate pp-styles pp-hooks)
  
  (begin
    (define *fold-case* #f)
    (define lpar #\()
    (define lbrk #\[)
    (define rpar #\))
    (define rbrk #\])
    
    (define (list->bytevector l)
      (define bv (make-bytevector (length l)))
      (do ((l l (cdr l)) (i 0 (+ i 1))) ((null? l) bv)
        (bytevector-u8-set! bv i (car l))))
    
    
    (define (read-decorated port)
      (define (r-error p msg . args)
        (apply error "decorated reader:" msg args))
      
      (define (atomic? form)
        (not (or (pair? form) (and (vector? form) (> (vector-length form) 0))
                 (and (string? form) (> (string-length form) 0)))))
      
      (define decorations '())
      (define (decorate! form hc* tc)
        (unless (or (atomic? form) (and (not tc) (null? hc*)))
          (set! decorations
            (cons (cons form (cons tc hc*)) decorations))))
      
      (define-values (reader-token? close-paren close-bracket dot)
        (let ((rtm (list 'reader-token)))
          (values
            (lambda (form) (and (pair? form) (eq? (car form) rtm)))
            (cons rtm "right parenthesis") (cons rtm "right bracket")
            (cons rtm "dot"))))
      
      (define (ws-tail p)
        (let ((c (peek-char p)))
          (cond ((eqv? c #\newline) (read-char p) #f) ; end of tail
                ((and (char? c) (char-whitespace? c))
                 (read-char p)
                 (ws-tail p))
                ((eqv? c #\;) (read-line p))
                (else #f))))
      
      (define (sub-read-carefully p)
        (let ((form (sub-read p)))
          (cond ((eof-object? form) (r-error p "unexpected end of file"))
                ((reader-token? form)
                 (r-error p "unexpected token" (cdr form)))
                (else form))))
      
      (define (char-delimiter? c)
        (or (char-whitespace? c) (char=? c lpar) (char=? c rpar)
            (char=? c lbrk) (char=? c rbrk) (char=? c #\")
            (char=? c #\|) (char=? c #\;)))
      
      (define (char-symbolic? c)
        (or (char-alphabetic? c) (char-numeric? c)
            (memv c
                  '(#\!
                    #\$
                    #\%
                    #\&
                    #\*
                    #\/
                    #\:
                    #\<
                    #\=
                    #\>
                    #\?
                    #\^
                    #\_
                    #\~
                    #\+
                    #\-
                    #\.
                    #\@))))
      
      (define (sub-scan-to-delimiter c p)
        (let loop ((l (list c)))
          (let ((c (peek-char p)))
            (cond ((or (eof-object? c) (char-delimiter? c))
                   (list->string (reverse l)))
                  (else (loop (cons (read-char p) l)))))))
      
      (define (sub-read-to-delimiter c p)
        (let ((s (sub-scan-to-delimiter c p)))
          (if (string=? s ".")
              dot
              (read (open-input-string
                      (if *fold-case* (string-append "#!fold-case " s) s))))))
      
      (define (sub-read-char p)
        (let ((c (read-char p)))
          (if (eof-object? c)
              (r-error p "end of file after #\\")
              (let ((nc (peek-char p)))
                (if (or (eof-object? nc) (char-delimiter? nc))
                    c
                    (let ((s (sub-scan-to-delimiter c p)))
                      (read (open-input-string (string-append "#\\" s)))))))))
      
      (define (sub-read p)
        (define hc* '())
        (define form
          (let loop ((c (peek-char p)))
            (cond ((eof-object? c) c)
                  ((char=? c #\newline)
                   (read-char p)
                   (set! hc* (cons "" hc*))
                   (loop (peek-char p)))
                  ((char-whitespace? c) (read-char p) (loop (peek-char p)))
                  ((char=? c #\;)
                   (set! hc* (cons (read-line p) hc*))
                   (loop (peek-char p)))
                  ((char=? c lpar)
                   (read-char p)
                   (sub-read-list p close-paren #t))
                  ((char=? c rpar) (read-char p) close-paren)
                  ((char=? c lbrk)
                   (read-char p)
                   (sub-read-list p close-bracket #t))
                  ((char=? c rbrk) (read-char p) close-bracket)
                  ((char=? c #\')
                   (read-char p)
                   (list 'quote (sub-read-carefully p)))
                  ((char=? c #\`)
                   (read-char p)
                   (list 'quasiquote (sub-read-carefully p)))
                  ((char-symbolic? c) (sub-read-to-delimiter (read-char p) p))
                  ((char=? c #\,)
                   (read-char p)
                   (let ((next (peek-char p)))
                     (cond ((eof-object? next) (r-error p "end of file after ,"))
                           ((char=? next #\@)
                            (read-char p)
                            (list 'unquote-splicing (sub-read-carefully p)))
                           (else (list 'unquote (sub-read-carefully p))))))
                  ((char=? c #\") (read p))
                  ((char=? c #\|) (read p))
                  ((char=? c #\#)
                   (read-char p)
                   (let ((c (peek-char p)))
                     (cond ((eof-object? c) (r-error p "end of file after #"))
                           ((char=? c #\!)
                            (let ((str (sub-scan-to-delimiter #\# p)))
                              (cond ((string=? str "#!fold-case") (set! *fold-case* #t))
                                    ((string=? str "#!no-fold-case")
                                     (set! *fold-case* #f))
                                    (else (r-error p "unexpected directive" str))))
                            (loop (peek-char p)))
                           ((or (char-ci=? c #\t) (char-ci=? c #\f) (char-ci=? c #\b)
                                (char-ci=? c #\o) (char-ci=? c #\d) (char-ci=? c #\x)
                                (char-ci=? c #\i) (char-ci=? c #\e))
                            (sub-read-to-delimiter #\# p))
                           ((char=? c #\;) ; not used as a decoration
                            (read-char p)
                            (sub-read-carefully p)
                            (loop (peek-char p)))
                           ((char=? c #\|) ; not used as a decoration
                            (read-char p)
                            (let recur ()
                              (let ((next (read-char p)))
                                (cond ((eof-object? next)
                                       (r-error p "end of file in #| comment"))
                                      ((char=? next #\|)
                                       (let ((next (peek-char p)))
                                         (cond ((eof-object? next)
                                                (r-error p "end of file in #| comment"))
                                               ((char=? next #\#) (read-char p))
                                               (else (recur)))))
                                      ((char=? next #\#)
                                       (let ((next (peek-char p)))
                                         (cond ((eof-object? next)
                                                (r-error p "end of file in #| comment"))
                                               ((char=? next #\|)
                                                (read-char p)
                                                (recur)
                                                (recur))
                                               (else (recur)))))
                                      (else (recur)))))
                            (loop (peek-char p)))
                           ((char=? c lpar)
                            (read-char p)
                            (list->vector (sub-read-list p close-paren #f)))
                           ((char=? c #\u)
                            (read-char p)
                            (if (and (eq? (read-char p) #\8) (eq? (read-char p) lpar))
                                (list->bytevector (sub-read-list p close-paren #f))
                                (r-error p "invalid bytevector syntax")))
                           ((char=? c #\&) (read-char p) (box (sub-read-carefully p)))
                           ((char=? c #\u)
                            (read-char p)
                            (if (and (eq? (read-char p) #\8) (eq? (read-char p) lpar))
                                (list->bytevector (sub-read-list p close-paren #f)) ; fixme?
                                (r-error p "invalid bytevector syntax")))
                           ((char=? c #\\) (read-char p) (sub-read-char p))
                           ((char-numeric? c)
                            (r-error p "#N=/#N# notation not supported"))
                           (else (r-error p "unknown # syntax" c)))))
                  ; NB: we can fall back on read, but it won't observe *fold-case*
                  (else (read p)))))
        (define tc (if (reader-token? form) #f (ws-tail p)))
        (unless (reader-token? form)
          (decorate! form (reverse hc*) tc))
        form)
      
      (define (sub-read-list p close-token dot?)
        (let ((form (sub-read p)))
          (if (eq? form dot)
              (r-error p "missing car: ( immediately followed by .") ;)
              (let recur ((form form))
                (cond ((eof-object? form)
                       (r-error p "eof inside list: unbalanced parentheses"))
                      ((eq? form close-token) '())
                      ((eq? form dot)
                       (if dot?
                           (let* ((last-form (sub-read-carefully p))
                                  (another-form (sub-read p)))
                             (if (eq? another-form close-token)
                                 last-form
                                 (r-error p "randomness after form after dot" another-form)))
                           (r-error p "dot in #(...)")))
                      ((reader-token? form)
                       (r-error p "error inside list:" (cdr form)))
                      ; this is the pair that will be in the final object
                      (else (cons form (recur (sub-read p)))))))))
      
      ; body of read-decorated
      (let ((form (sub-read port)))
        (if (not (reader-token? form))
            (values form decorations)
            (r-error port "unexpected token:" (cdr form)))))
    
    
    ; pretty-printer that optionally uses decorated reader
    
    (define (pprint-file ifn . rest)
      (define-values (ofn kv*)
        (if (and (pair? rest) (string? (car rest)))
            (values (car rest) (cdr rest))
            (values #f rest)))
      (define decorate?
        (cond ((memq pp-decorate kv*) =>
               (lambda (p) (and (pair? (cdr p)) (cadr p))))
              (else (pp-decorate))))
      (define (parse-magic-line line)
        (define (skip-while p pred)
          (let ((c (peek-char p)))
            (when (and (not (eof-object? c)) (pred c))
              (read-char p)
              (skip-while p pred))))
        (define (read-or-eof p)
          (define x (guard (ex (else (eof-object))) (read p)))
          (case x ((t) #t) ((nil) #f) (else x)))
        (define (parse-kv p)
          (let* ((key (read-or-eof p)) (m (assq key file-key-map)))
            (and m
                 (let ((val (read-or-eof p)))
                   (and (not (eof-object? val)) (list (cdr m) val))))))
        (define (parse-kvs p)
          (let loop ((kvs '()))
            (skip-while p char-whitespace?)
            (if (eqv? (peek-char p) #\-)
                (reverse kvs)
                (let ((kv (parse-kv p)))
                  (skip-while p char-whitespace?)
                  (when (eqv? (peek-char p) #\;) (read-char p))
                  (loop (if kv (cons kv kvs) kvs))))))
        (call-with-port (open-input-string line)
          (lambda (p)
            (skip-while p (lambda (ch) (char=? ch #\;)))
            (and (eq? (read-or-eof p) '-*-)
                 (let ((kvs (parse-kvs p)))
                   (and (eq? (read-or-eof p) '-*-) (apply append kvs)))))))
      (define (copy-whitespace ip op)
        (let loop ((c (peek-char ip)))
          (when (and (char? c) (char-whitespace? c))
            (write-char (read-char ip) op)
            (loop (peek-char ip)))))
      (define (copy-top-line-comments ip op in-header?)
        (copy-whitespace ip op)
        (when (eqv? (peek-char ip) #\;)
          (let ((line (read-line ip)))
            (cond ((and in-header? (parse-magic-line line)) =>
                   (lambda (kvs)
                     (set! kv* (append kv* kvs))
                     (set! in-header? #f))))
            (display line op)
            (newline op)
            (copy-top-line-comments ip op in-header?))))
      (define (pf ip op)
        (let loop ((in-header? #t))
          (copy-top-line-comments ip op in-header?)
          (let-values (((obj decs) (read-decorated ip)))
            (unless (eof-object? obj)
              (pp* obj op pp-code #t pp-newline #t pp-decorate
                   (lambda (x) (cond ((assq x decs) => cdr) (else #f))) kv*)
              (loop #f)))))
      (if (eq? decorate? #t)
          (call-with-input-file ifn
            (lambda (ip)
              (if (not ofn)
                  (pf ip (current-output-port))
                  (call-with-output-file ofn (lambda (op) (pf ip op))))))
          (apply advanced-pprint-file ifn rest)))
    
    
    (define (html-emit s op)
      (let loop ((i 0) (n (string-length s)))
        (unless (>= i n)
          (let ((c (string-ref s i)))
            (case c
              ((#\<) (write-string "&lt;" op))
              ((#\>) (write-string "&gt;" op))
              ((#\&) (write-string "&amp;" op))
              (else (write-char c op))))
          (loop (+ i 1) n))))
    
    (define (html-color-mapper sc start?)
      (if start?
          (string-append "<span class=\"" (symbol->string sc) "\">")
          "</span>"))
    
    ; assumes color-mapper is based on sgr palette
    (define (sc->fg-rgb sc cm)
      (define tier 3) ; get full rgb color
      (define cv (cm sc tier)) ; expect sgr bundle
      (define (parse-cs cs)
        (define p (open-input-string cs))
        (define r #f)
        (define g #f)
        (define b #f)
        (and (eqv? (read p) 38) (eqv? (read-char p) #\;)
             (eqv? (read p) 2) (eqv? (read-char p) #\;)
             (begin (set! r (read p)) (number? r))
             (eqv? (read-char p) #\;)
             (begin (set! g (read p)) (number? g))
             (eqv? (read-char p) #\;)
             (begin (set! b (read p)) (number? b))
             (eof-object? (read-char p)) (+ (* r 65536) (* g 256) b)))
      (and (vector? cv) (= (vector-length cv) 4)
           (string? (vector-ref cv 3))
           (let ((s (vector-ref cv 3)))
             (cond ((string=? s "1") 'bold)
                   ((string=? s "2") 'dim)
                   (else (parse-cs s))))))
    
    (define (hex rgb)
      (let ((s (number->string rgb 16)))
        (string-append (make-string (- 6 (string-length s)) #\0) s)))
    
    (define (sc->class-def sc cm)
      (define rgb (sc->fg-rgb sc cm))
      (cond ((number? rgb)
             (string-append "." (symbol->string sc) " { color: #"
               (hex rgb) "; }"))
            ((eq? rgb 'bold)
             (string-append "." (symbol->string sc) " { color: #"
               (hex 15527924) "; font-weight: bold; }"))
            (else #f)))
    
    (define (display-class-defs cm op)
      (define sc*
        '(comment
          char
          string
          escape
          formal
          variable
          defined
          keyword
          number
          literal
          meta
          directive
          paren
          bracket
          warning))
      (define (pr s) (display s op))
      (let loop ((sc* sc*))
        (unless (null? sc*)
          (let ((cds (sc->class-def (car sc*) cm)))
            (when (string? cds) (pr "  ") (pr cds) (pr "\n")))
          (loop (cdr sc*)))))
    
    (define (display-html-header cm op)
      (define bg-rgb 1842982)
      (define fg-rgb 13948116)
      (define (pr s) (display s op))
      (define (prl s) (pr s) (pr "\n"))
      (prl "<!DOCTYPE html>")
      (prl "<html>")
      (prl "<head>")
      (prl "<style>") ; todo: takefg / bg colors from the palette
      (pr "  body { background-color: #")
      (pr (hex bg-rgb))
      (pr "; color: #")
      (pr (hex fg-rgb))
      (prl "; margin: 0; padding: 2em; }")
      (prl "  pre {")
      (prl "    font-family: 'Consolas', 'Monaco', 'Andale Mono', 'Ubuntu Mono', monospace;")
      (prl "    font-size: 10pt; line-height: 2.75ex; white-space: pre-wrap;")
      (prl "  }")
      (display-class-defs cm op)
      (prl "</style>")
      (prl "</head>")
      (prl "<body>")
      (pr "<pre>"))
    
    (define (display-html-footer op)
      (define (pr s) (display s op))
      (define (prl s) (pr s) (pr "\n"))
      (prl "</pre>")
      (prl "</body>")
      (prl "</html>"))
    
    ; map for Emacs-like file variables, mapped to parameters
    ; see https://www.gnu.org/software/emacs/manual/html_node/emacs/Specifying-File-Variables.html
    (define file-key-map
      `((pp-width: unquote pp-width)
        (fill-column: unquote pp-width) ; Emacs standard 
        (pp-inline-width: unquote pp-inline-width)
        (pp-miser-width: unquote pp-miser-width)
        (pp-tab: unquote pp-tab)
        (pp-max-tab: unquote pp-max-tab)
        (pp-brackets: unquote pp-brackets)))
    
    ; reads input file, pretty-prints it to output file or current output
    ; top-level line comments are preserved, -*- line is recognized in the header
    (define (pprint-file/html ifn . rest)
      (define-values (ofn kv*)
        (if (and (pair? rest) (string? (car rest)))
            (values (car rest) (cdr rest))
            (values #f rest)))
      (define decorate?
        (cond ((memq pp-decorate kv*) =>
               (lambda (p) (and (pair? (cdr p)) (cadr p))))
              (else (pp-decorate))))
      (define ccm
        (let ((r (memq pp-color kv*)))
          (if (and (pair? r) (pair? (cdr r)) (procedure? (cadr r)))
              (cadr r)
              (pp-color))))
      (define cm (or ccm default-semantic-color-mapper))
      (define (parse-magic-line line)
        (define (skip-while p pred)
          (let ((c (peek-char p)))
            (when (and (not (eof-object? c)) (pred c))
              (read-char p)
              (skip-while p pred))))
        (define (read-or-eof p)
          (define x (guard (ex (else (eof-object))) (read p)))
          (case x ((t) #t) ((nil) #f) (else x)))
        (define (parse-kv p)
          (let* ((key (read-or-eof p)) (m (assq key file-key-map)))
            (and m
                 (let ((val (read-or-eof p)))
                   (and (not (eof-object? val)) (list (cdr m) val))))))
        (define (parse-kvs p)
          (let loop ((kvs '()))
            (skip-while p char-whitespace?)
            (if (eqv? (peek-char p) #\-)
                (reverse kvs)
                (let ((kv (parse-kv p)))
                  (skip-while p char-whitespace?)
                  (when (eqv? (peek-char p) #\;) (read-char p))
                  (loop (if kv (cons kv kvs) kvs))))))
        (call-with-port (open-input-string line)
          (lambda (p)
            (skip-while p (lambda (ch) (char=? ch #\;)))
            (and (eq? (read-or-eof p) '-*-)
                 (let ((kvs (parse-kvs p)))
                   (and (eq? (read-or-eof p) '-*-) (apply append kvs)))))))
      (define (copy-whitespace ip op)
        (let loop ((c (peek-char ip)))
          (when (and (char? c) (char-whitespace? c))
            (write-char (read-char ip) op)
            (loop (peek-char ip)))))
      (define (copy-comment cs op)
        (write-string
          (semantic-color->start-string 'comment html-color-mapper)
          op)
        (html-emit cs op)
        (write-string
          (semantic-color->end-string 'comment html-color-mapper)
          op)
        (newline op))
      (define (copy-top-line-comments ip op in-header?)
        (copy-whitespace ip op)
        (when (eqv? (peek-char ip) #\;)
          (let ((line (read-line ip)))
            (cond ((and in-header? (parse-magic-line line)) =>
                   (lambda (kvs)
                     (set! kv* (append kvs kv*))
                     (set! in-header? #f))))
            (copy-comment line op)
            (copy-top-line-comments ip op in-header?))))
      (define (pf ip op)
        (display-html-header cm op)
        (let loop ((in-header? #t))
          (when decorate? (copy-top-line-comments ip op in-header?))
          (let-values (((obj decs) (read-decorated ip)))
            (unless (eof-object? obj)
              (pp* obj op pp-code #t pp-newline #t pp-decorate
                   (lambda (x) (cond ((assq x decs) => cdr) (else #f))) pp-emit
                   html-emit pp-color html-color-mapper kv*)
              (unless decorate? (newline op))
              (loop #f))))
        (display-html-footer op))
      (call-with-input-file ifn
        (lambda (ip)
          (if (not ofn)
              (pf ip (current-output-port))
              (call-with-output-file ofn (lambda (op) (pf ip op)))))))))

