;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; schematic-format.scm
;;;
;;; This is a program for formatting Scheme source. Currently, that
;;; means slightly opinionated autoindentation of R7RS forms.
;;;
;;; 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).
;;;   * User-defined indentation rules.
;;;
;;; See this project's README for more information.
;;;
;;; Copyright (c) 2013, Evan Hanson <evhan@foldling.org>
;;; See LICENSE for details.
;;;

(cond-expand
  (chicken ; R7RS shims.
   (require-extension (only extras read-line))
   (define string-copy substring)
   (define (bytevector? o) #f)
   (define (close-port p)
     ((if (output-port? p) close-output-port close-input-port) p))
   (define (call-with-port p f)
     (let ((r (f p))) (close-port p) r))
   (define-syntax guard
     (syntax-rules ()
       ((_ (e . c) . b)
        (handle-exceptions e (cond . c) . b)))))
  (r7rs
   (import (scheme base)
           (scheme case-lambda)
           (scheme char)
           (scheme process-context)
           (scheme read)
           (scheme write))))

(define program-version "0.1.1")

;; 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)))))

;; `string-ref`, returning `d` when `i` is (positively) out of bounds.
(define string-ref
  (let ((string-ref 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`, or `#f` if that
;; would be an end-of-file object.
;;
;; 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)))
    ((str n start)
     (string-nth-read-index str n start (string-length str)))
    ((str n start end)
     (call-with-input-string
      (string-copy str start end)
      (lambda (s)
        ;; Read `n` forms.
        (guard/value #f
          (do ((n n (- n 1)))
              ((zero? n))
            (read s)))
        ;; Eat whitespace.
        (do ((c (peek-char s) (peek-char s)))
            ((or (eof-object? c) (not (char-whitespace? c))))
          (read-char s))
        ;; Return the index of the remaining substring.
        (let ((c (peek-char s)))
          (and (not (eof-object? c))
               (not (char=? c #\;))
               (- end (string-length (read-string 65535 s))))))))))

;; Read whitespace, returning a numerical indent level (in spaces).
;; Tabstop is hardcoded at eight.
(define read-indent
  (case-lambda
    (()
     (read-indent (current-input-port)))
    ((input)
     (let lp ((n 0))
       (case (peek-char input)
         ((#\space) (read-char input)
                    (lp (+ n 1)))
         ((#\tab)   (read-char input)
                    (lp (+ n 8)))
         (else n))))))

;;
;; `keyword-indentation-offset` 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-indentation-offset 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)
    (else #f)))

;; Reformat the Scheme code on `input` into `output`.
(define format-scheme
  (case-lambda
    (()
     (format-scheme (current-input-port) (current-output-port)))
    ((input)
     (format-scheme input (current-output-port)))
    ((input output)
     (let loop ((forms (list (read-indent input))))
       (let ((line (read-line input)))
         (unless (eof-object? line)
           (let ((form (car forms)))
             (let-values (((line indent)
                           (if (symbol? form)
                               (values line 0)
                               (values (string-trim line)
                                       (if (number? form)
                                           form
                                           (car form))))))
               (unless (zero? indent)
                 (display (make-string indent #\space) output))
               (display line output)
               (newline output)
               (let ((len (string-length line)))
                 (let scan ((f forms)
                            (i 0))
                   (cond
                     ((null? f))
                     ((>= i len) (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)
                           ((#\;) (loop f))
                           ((#\") (scan (cons 'string f) (+ i 1)))
                           ((#\|) (scan (cons 'symbol f) (+ i 1)))
                           ((#\)) (scan (cdr f) (+ i 1)))
                           ((#\() (let* ((i (+ i 1))
                                         (a (guard/value #f (string-read line i len)))
                                         (k (string-nth-read-index line 1 i len))
                                         (f (cond ((number? (car f)) f)        ; No queue.
                                                  ((null? (cdar f)) f)         ; Exhausted.
                                                  ((cons (cdar f) (cdr f)))))) ; Shift.
                                    (cond
                                      ((constant? a)
                                       (scan (cons (+ i indent) f) i))
                                      ((keyword-indentation-offset 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)))))
                           ((#\#) (case (string-ref line (+ i 1) #f)
                                    ((#\|) (scan (cons 'comment f) (+ i 2)))
                                    ((#\;) (scan f (+ i 2)))
                                    (else  (scan f (or (string-nth-read-index line 1 i len)
                                                       (+ i 1))))))
                           (else  (scan f (or (string-nth-read-index line 1 i len)
                                              (+ i 1)))))))))))))))))))

(for-each
 (lambda (option)
   (cond
     ((member option '("-v" "--version"))
      (for-each display (list program-version #\newline))
      (exit))
     ((member option '("-h" "--help"))
      (for-each display (list "Usage: " (car (command-line)) #\newline))
      (exit))
     (else
      (parameterize ((current-output-port (current-error-port)))
        (for-each display (list "Unrecognized command line option: " option #\newline))
        (exit 1)))))
 (cdr (command-line)))

(format-scheme
 (current-input-port)
 (current-output-port))