;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; schematic/format.scm
;;;
;;; This is a formatter for Scheme source. It provides a procedure,
;;; `format-scheme`, that reads Scheme from an input port, reindents it
;;; according to a fairly conventional set of rules, and writes it to an
;;; output port.
;;;
;;; This is not a pretty-printer! Formatting source code and pretty
;;; printing S-expressions are two different tasks, and this program
;;; does the former. It will not introduce line breaks or change
;;; intraline spacing; it will modify line indentation.
;;;
;;; Still TODO:
;;;
;;;   * `=>` in `cond` forms (should not set a new indentation level).
;;;
;;; See this project's README for more information.
;;;
;;; Copyright (c) 2013-2018, Evan Hanson <evhan@foldling.org>
;;; See LICENSE for details.
;;;

;; When `(bracket-closure?)` is non-false, a single closing bracket
;; (`#\]`) will cause `format-scheme` to insert closing parentheses for
;; all open forms before continuing to process input.
(define bracket-closure? (make-parameter #f))

;; When `(bracket-parentheses?)` is non-false, `format-scheme` will
;; treat brackets as though they were parentheses.
(define bracket-parentheses? (make-parameter #f))

;; When `(tabstop-length)` is non-false, `format-scheme` will indent
;; lines first with tabs of the specified tabstop (that is, an
;; equivalent length in spaces), then with spaces for all remaining
;; columns. This value should be a positive integer.
(define tabstop-length (make-parameter #f))

;; Perform body `b`, returning the result of `e` on _any_ error.
(define-syntax guard/value
  (syntax-rules ()
    ((_ e . b) (let ((v e)) (guard (_ (else v)) . b)))))

(define (call-with-input-string s f)
  (call-with-port (open-input-string s) f))

(define (constant? o) ; Except `symbol?`.
  (or (boolean? o) (char? o) (number? o) (string? o) (vector? o) (bytevector? o)))

;; Trim `char-whitespace?` from the front (i.e. left) of `str`.
(define (string-trim str)
  (let ((len (string-length str)))
    (do ((i 0 (+ i 1)))
        ((or (= i len)
             (not (char-whitespace? (string-ref str i))))
         (string-copy str i len)))))

;; Does every char in `str` satisfy `pred?`?
(define (string-every? str pred?)
  (let ((len (string-length str)))
    (let loop ((i 0))
      (or (= i len)
          (and (pred? (string-ref str i))
               (loop (+ i 1)))))))

;; `string-ref`, returning `d` when `i` is (positively) out of bounds.
(define string-ref*
  (case-lambda
    ((s i)   (string-ref s i))
    ((s i d) (if (<= (string-length s) i)
                 d
                 (string-ref s i)))))

;; Read a single Scheme object from `str`.
(define string-read
  (case-lambda
    ((str)
     (call-with-input-string str read))
    ((str start)
     (call-with-input-string (string-copy str start) read))
    ((str start end)
     (call-with-input-string (string-copy str start end) read))))

;; Return the index of the `n`th Scheme object in `str`. If the end of
;; `str` is reached, return `default`. If an error occurs, return `#f`.
;;
;; NB This is not efficient for large `n`! It reads into the string `n`
;; times (truly, with `read`), seeks to the next token, then compares
;; the remaining substring's length to the original's.
(define string-nth-read-index
  (case-lambda
    ((str n)
     (string-nth-read-index str n 0 (string-length str) #f))
    ((str n start)
     (string-nth-read-index str n start (string-length str) #f))
    ((str n start end)
     (string-nth-read-index str n start end #f))
    ((str n start end default)
     (call-with-input-string
      (string-copy str start end)
      (lambda (s)
        (and ;; Read `n` forms.
             (guard/value #f
               (do ((n n (- n 1)))
                   ((zero? n) #t)
                 (read s)))
             ;; Eat whitespace.
             (do ((c (peek-char s) (peek-char s)))
                 ((or (eof-object? c) (not (char-whitespace? c))) #t)
               (read-char s))
             ;; Return the index of the remaining substring.
             (let ((c (peek-char s)))
               (if (or (eof-object? c) (char=? c #\;))
                   default
                   (- end (string-length (read-string 65535 s)))))))))))

;; Read whitespace, returning a numerical indent level (in spaces).
;; If `(tabstop-length)` is false, tabs are treated as eight spaces.
(define read-indent
  (case-lambda
    (()
     (read-indent (current-input-port)))
    ((input)
     (let ((ts (or (tabstop-length) 8)))
       (let lp ((n 0))
         (case (peek-char input)
           ((#\space) (read-char input)
                      (lp (+ n 1)))
           ((#\tab)   (read-char input)
                      (lp (+ n ts)))
           (else n)))))))

;; Write whitespace for the given numerical indentation level to
;; `output`. If `(tabstop-length)` is non-false, a combination of tabs
;; and spaces will be written. Otherwise, only spaces will be used.
(define display-indent
  (case-lambda
    ((indent)
     (display-indent indent (current-output-port)))
    ((indent output)
     (let ((ts (tabstop-length)))
       (cond ((<= indent 0))
             ((not ts)
              (display (make-string indent #\space) output))
             (else
              (display (make-string (quotient indent ts) #\tab) output)
              (display (make-string (remainder indent ts) #\space) output)))))))

;;
;; `keyword-indent` determines the horizontal alignment of a
;; keyword's subforms. This is a numerical offset from the keyword's
;; position, or `#f` to forego any special treatment. `eol?` is a
;; boolean indicating whether the keyword is the final token in its
;; line.
;;
;; A value of zero will horizontally align all leading subforms on
;; ensuing lines with the keyword:
;;
;;     (foo bar
;;      baz
;;      qux)
;;
;; A value of one will adjust the indent level accordingly:
;;
;;     (foo bar
;;       baz
;;       qux)
;;
;; And so on.
;;
(define (keyword-indent sym eol?)
  (case sym
    ((begin cond) (and eol? 1))
    ((call-with-port) 0)
    ((case) 1)
    ((cond-expand) 1)
    ((define define-values) 1)
    ((define-library) 1)
    ((define-record-type) 1)
    ((define-syntax syntax-rules) 1)
    ((do) '(0 3 1))
    ((guard) 1)
    ((lambda case-lambda) 1)
    ((let let*) 1)
    ((let-syntax letrec-syntax) 1)
    ((let-values let*-values) 1)
    ((letrec letrec*) 1)
    ((parameterize) 1)
    ((set!) 1)
    ((when unless) 1)
    ((with-exception-handler) 0)
    ((with-input-from-file call-with-input-file) 0)
    ((with-output-to-file call-with-output-file) 0)
    (else #f)))

;; Keywords may push a queue of indentation offsets onto the form
;; stack, which is repeatedly shifted to obtain the next indent level
;; (until it's exhausted, at which point the final value of the queue
;; applies as usual).
(define (shift-indent forms)
  (cond ((number? (car forms)) forms)       ; No queue.
        ((null? (cdar forms)) forms)        ; Exhausted.
        ((cons (cdar forms) (cdr forms))))) ; Shift.

;; Reformat the Scheme code on `input` into `output`.
(define format-scheme
  (case-lambda
    (()
     (format-scheme keyword-indent (current-input-port) (current-output-port)))
    ((input)
     (format-scheme keyword-indent input (current-output-port)))
    ((input output)
     (format-scheme keyword-indent input output))
    ((custom-keyword-indent input output)
     (let ((initial-indent (list (read-indent input)))
           (display-line   (lambda (line indent)
                             (unless (string-every? line char-whitespace?)
                               (display-indent indent output)
                               (display line output))
                             (newline output))))
       (let loop ((forms initial-indent))
         (unless (eof-object? (peek-char input))
           (let ((line (read-line input)))
             (let ((form (car forms)))
               (let-values (((line indent)
                             (if (symbol? form)
                                 (values line 0)
                                 (values (string-trim line)
                                         (if (number? form)
                                             form
                                             (car form))))))
                 (let ((len (string-length line)))
                   (let scan ((f forms)
                              (i 0))
                     (define (open i)
                       (let* ((a (guard/value #f (string-read line i len)))
                              (k (string-nth-read-index line 1 i len #f))
                              (f (shift-indent f)))
                         (cond
                           ((constant? a)
                            (scan (cons (+ i indent) f) i))
                           ((custom-keyword-indent a (not k))
                            => (lambda (offset)
                                 (scan (if (number? offset)
                                           (cons (+ i offset indent) f)
                                           (cons (map (lambda (o) (+ i o indent)) offset) f))
                                       (or k len))))
                           ((not k)
                            (scan (cons (+ i indent) f) i))
                           (else
                            (scan (cons (+ k indent) f) k)))))
                     (define (close i)
                       (scan (cdr f) i))
                     (define (datum i n)
                       (let ((k (string-nth-read-index line 1 i len len)))
                         (if (not k)
                             (scan f (+ i n))
                             (scan (shift-indent f) k))))
                     (cond
                       ((null? f) ; The front fell off.
                        (display-line line indent)
                        (loop initial-indent))
                       ((>= i len) ; End of line.
                        (display-line line indent)
                        (loop f))
                       (else
                        (case (car f)
                          ((comment)
                           (case (string-ref line i)
                             ((#\|) (case (string-ref* line (+ i 1) #f)
                                      ((#\#) (scan (cdr f) (+ i 2)))
                                      (else  (scan f (+ i 1)))))
                             ((#\#) (case (string-ref* line (+ i 1) #f)
                                      ((#\|) (scan (cons 'comment f) (+ i 2)))
                                      (else  (scan f (+ i 1)))))
                             (else  (scan f (+ i 1)))))
                          ((string)
                           (case (string-ref line i)
                             ((#\") (scan (cdr f) (+ i 1)))
                             ((#\\) (scan f (+ i 2)))
                             (else  (scan f (+ i 1)))))
                          ((symbol)
                           (case (string-ref line i)
                             ((#\|) (scan (cdr f) (+ i 1)))
                             ((#\\) (scan f (+ i 2)))
                             (else  (scan f (+ i 1)))))
                          (else
                           (case (string-ref line i)
                             ((#\;) (scan f len)) ; Skip to the end.
                             ((#\") (scan (cons 'string f) (+ i 1)))
                             ((#\|) (scan (cons 'symbol f) (+ i 1)))
                             ((#\() (open (+ i 1)))
                             ((#\)) (close (+ i 1)))
                             ((#\[) (cond
                                      ((bracket-parentheses?)
                                       (open (+ i 1)))
                                      (else
                                       (scan f (+ i 1)))))
                             ((#\]) (cond
                                      ((bracket-parentheses?)
                                       (close (+ i 1)))
                                      ((bracket-closure?)
                                       (set! line ; Insert closing parentheses for all `f`.
                                         (string-append (string-copy line 0 i)
                                                        (make-string (length (cdr f)) #\))
                                                        (string-copy line (+ i 1))))
                                       (set! len
                                         (string-length line))
                                       (scan initial-indent i))
                                      (else
                                       (scan f (+ i 1)))))
                             ((#\#) (case (string-ref* line (+ i 1) #f)
                                      ((#\|) (scan (cons 'comment f) (+ i 2)))
                                      ((#\;) (datum i 2))
                                      ((#\\) (datum i 3))
                                      (else  (datum i 1))))
                             (else  (datum i 1))))))))))))))))))