;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; Program analysis and linting.
;;;
;;; Copyright (c) 2018, Evan Hanson
;;;
;;; See LICENSE for details.
;;;

(declare
  (module (beaker)))

(define (configure-compiler-extension)
  (import (chicken sort)
          (chicken plist)
          (chicken compiler user-pass)
          (prefix (chicken internal) internal-)
          (except (srfi 69) hash-table-for-each)
          (srfi 1)
          (srfi 13))

  (define imported-modules (make-hash-table))
  (define referenced-modules (make-hash-table))

  (define (symbol<? x y)
    (string<? (symbol->string x) (symbol->string y)))

  (define (symbol-namespace sym)
    (and-let* ((str (symbol->string sym))
               (sep (string-index str #\#)))
      (string->symbol (substring str 0 sep))))

  (define (collect-referenced-modules! db)
    ((flip internal-hash-table-for-each)
     db
     (lambda (sym props)
       (and-let* ((n (symbol-namespace sym)))
         (hash-table-set! referenced-modules n 'value)))))

  (define (collect-preprocessor-information! x)
    (let loop ((x x))
      (cond ((symbol? x)
             ((flip for-each)
              (get x '##core#db '())
              (lambda (item)
                (when (eq? (car item) 'syntax)
                  (hash-table-set! referenced-modules (cadr item) 'syntax)))))
            ((atom? x))
            ((eq? (car x) 'import)
             ((flip for-each)
              (cdr x)
              (lambda (i)
                (receive (m . _) (##sys#decompose-import i values eq? 'import)
                  (hash-table-set! imported-modules
                                   m
                                   (or (get-line-number i)
                                       (get-line-number x)))))))
            (else
             (loop (car x))
             (loop (cdr x))))))

  (define (emit severity rule line-number-table items)
    (for-each (lambda (x)
                (write (cons* severity rule x))
                (newline))
              (sort (map (lambda (x)
                           (list (hash-table-ref line-number-table x) x))
                         items)
                    (lambda (x y)
                      (string<? (car x) (car y))))))

  (define (print-analysis-results)
    (let* ((imported   (hash-table-keys imported-modules))
           (referenced (hash-table-keys referenced-modules))
           (difference (lset-difference eq? imported referenced)))
      (parameterize ((current-output-port (current-error-port)))
        (emit 'notice 'import imported-modules imported)
        (emit 'warning 'unnecessary-import imported-modules difference))))

  (user-preprocessor-pass
   (lambda (x)
     (collect-preprocessor-information! x)
     (values x)))

  (user-post-analysis-pass
   (lambda (pass db node get set count continue)
     (when (= count 1)
       (collect-referenced-modules! db)
       (print-analysis-results)))))

(let ()
  (import (chicken platform))
  (when (feature? #:compiler-extension)
    (configure-compiler-extension)))