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

(declare
  (module (beaker)))

(define (configure-compiler-extension)
  (import (chicken compiler user-pass)
          (chicken eval)
          (chicken format)
          (chicken internal)
          (chicken memory representation)
          (chicken plist)
          (chicken port)
          (chicken pretty-print)
          (chicken sort)
          (chicken string)
          (chicken syntax)
          (srfi 1)
          (srfi 13))

  (define imported-modules (make-vector 32 '()))
  (define referenced-modules (make-vector 32 '()))
  (define global-identifiers (make-vector 32 '()))
  (define warnings (make-vector 128 '()))
  (define deferred-analysers '())

  (define (warn type expr #!optional (loc (get-line-number expr)))
    (unless (not loc)
      (let ((item (cons type expr)))
        (hash-table-update!
         warnings
         (string->symbol loc)
         (lambda (warnings*)
           (alist-update! type expr warnings*))
         (lambda () (list item))))))

  (define (defer-analyser thunk)
    (set! deferred-analysers (cons thunk deferred-analysers)))

  (define (hash-table-keys table #!optional (comparator symbol<?))
    (let ((keys '()))
      (hash-table-for-each (lambda (k _) (set! keys (cons k keys))) table)
      (sort keys comparator)))

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

  (define (location<? x y)
    (let ((x* (string-split (symbol->string x) ":"))
          (y* (string-split (symbol->string y) ":")))
      (and (string<=? (car x*) (car y*))
           (< (string->number (cadr x*))
              (string->number (cadr y*))))))

  (define (pp-length x)
    (string-length (pp-string x)))

  (define (pp-string x)
    (with-output-to-string (lambda () (pp x))))

  (define (pp-fragment x #!optional (w 64) (d 5))
    (let loop ((x x) (w w) (d d))
      (cond ((memq x '(quote quasiquote unquote unquote-splicing)) x)
            ((string? x) x)
            ((symbol? x)
             (string->symbol (loop (format "~s" x) w d)))
            ((vector? x)
             (list->vector (loop (vector->list x) (sub1 w) d)))
            ((atom? x) x)
            ((or (negative? w) (negative? d))
             (list '...))
            (else
             (let* ((x*  (loop (car x) (sub1 w) (sub1 d)))
                    (x** (loop (cdr x) (- (sub1 w) (pp-length x*)) d)))
               (cons x* x**))))))

  (define (quasiquote? x)
    (and (pair? x) (eq? (car x) 'quasiquote)))

  (define (expression-contains? x pred)
    (cond ((pred x) #t)
          ((and (quasiquote? x) (vector? (cadr x)))
           (expression-contains? (vector->list (cadr x)) pred))
          ((pair? x)
           (or (expression-contains? (car x) pred)
               (expression-contains? (cdr x) pred)))
          (else #f)))

  (define (expression-contains-identifier? x id)
    (expression-contains? x (lambda (x*) (eq? x* id))))

  (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 hash-table-for-each)
     db
     (lambda (sym props)
       (and-let* ((mod (symbol-namespace sym)))
         (hash-table-set! referenced-modules mod 'value)))))

  (define (collect-referenced-syntax x)
    ((flip for-each)
     (get (car x) '##core#db '())
     (lambda (info)
       (when (eq? (car info) 'syntax)
         (hash-table-set! referenced-modules (cadr info) 'syntax)))))

  (define (analyse-import x)
    ((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)))))))

  (define (analyse-if x)
    (when (< (length x) 4)
      (warn 'one-armed-if x)))

  (define (analyse-cond x)
    (unless (assq 'else (cdr x))
      (warn 'missing-else x)))

  (define (analyse-case x)
    (unless (assq 'else (cddr x))
      (warn 'missing-else x)))

  (define (analyse-quasiquote x)
    (unless (expression-contains?
             x
             (lambda (x*)
               (and (pair? x*)
                    (or (eq? (car x*) 'unquote)
                        (eq? (car x*) 'unquote-splicing)))))
      (warn 'unnecessary-quasiquote x)))

  (define (analyse-let* x)
    (let loop ((vars (map car (cadr x)))
               (vals (map cdr (cadr x))))
      (cond ((null? vars) (warn 'unnecessary-let* x))
            ((expression-contains-identifier? vals (car vars)))
            (else (loop (cdr vars) (cdr vals))))))

  (define (analyse-quote x)
    (when (vector? (cadr x))
      (warn 'unnecessary-quote x)))

  (define (canonicalise-define x)
    (if (symbol? (cadr x))
        x
        (chicken.syntax#expand-curried-define (cadr x) (cddr x) '())))

  (define (analyse-define x)
    (hash-table-set! global-identifiers (cadr (canonicalise-define x)) #t))

  (define (analyse-set! x)
    (let ((sym (cadr x))
          (loc (get-line-number x)))
      (unless (compiler-ref sym)
        (defer-analyser
         (lambda ()
           (unless (hash-table-ref global-identifiers sym)
             (warn 'unbound-set! x loc)))))))

  (define (environment-ref env sym)
    (let ((x (assq sym env)))
      (and (pair? x)
           (if (atom? (cdr x))
               (cdr x)
               (caddr x)))))

  (define (module-ref mod sym)
    (environment-ref (block-ref (module-environment mod) 2) sym))

  (define (compiler-ref sym)
    (or (environment-ref (##sys#current-environment) sym)
        (environment-ref (##sys#macro-environment) sym)))

  (define (compiler-compare sym mod id)
    (eq? (compiler-ref sym) (module-ref mod id)))

  (define (analyse-expression x)
    (when (and (pair? x) (symbol? (car x)))
      (cond ((eq? (car x) 'import) (analyse-import x))
            ((compiler-compare (car x) 'scheme 'case) (analyse-case x))
            ((compiler-compare (car x) 'scheme 'cond) (analyse-cond x))
            ((compiler-compare (car x) 'scheme 'define) (analyse-define x))
            ((compiler-compare (car x) 'scheme 'if) (analyse-if x))
            ((compiler-compare (car x) 'scheme 'let*) (analyse-let* x))
            ;; NOTE disabled until quote line number tracking is added upstream
            ; ((compiler-compare (car x) 'scheme 'quasiquote) (analyse-quasiquote x))
            ; ((compiler-compare (car x) 'scheme 'quote) (analyse-quote x))
            ((compiler-compare (car x) 'scheme 'set!) (analyse-set! x))
            (else (collect-referenced-syntax x)))))

  (define (analyse-imports)
    (let* ((imported   (hash-table-keys imported-modules))
           (referenced (hash-table-keys referenced-modules))
           (difference (lset-difference eq? imported referenced)))
      (for-each (lambda (m)
                  (warn 'unnecessary-import (list m) (hash-table-ref imported-modules m)))
                difference)))

  (define (emit severity table)
    ((flip for-each)
     (hash-table-keys table location<?)
     (lambda (loc)
       ((flip for-each)
        (hash-table-ref table loc)
        (lambda (warning)
          (parameterize ((pretty-print-width 1024))
            (pretty-print
             (cons* (symbol->string loc) severity (car warning)
                    (pp-fragment (list (cdr warning)))))))))))

  (define (print-analysis-results)
    (parameterize ((current-output-port (current-error-port)))
      (emit 'warning warnings)))

  (set! ##sys#expand-0
    (let ((next ##sys#expand-0))
      (lambda (x e c)
        ;; NOTE we expand the form first so that the copmiler's
        ;; syntax checks run and we can assume the form is valid
        (receive (x* m) (next x e c)
          (analyse-expression x)
          (values x* m)))))

  (user-pass
   (let ((next (or (user-pass) values)))
     (lambda (x)
       (let ((analysers deferred-analysers))
         (set! deferred-analysers '())
         (for-each (lambda (f) (f)) analysers))
       (next x))))

  (user-post-analysis-pass
   (let ((done #f)
         (next (or (user-post-analysis-pass) void)))
     (lambda (pass db node get set count continue)
       (next pass db node get set count continue)
       (when (and (not done)
                  (or (eq? pass 'scrutiny)
                      (and (eq? pass 'opt) (= count 1))))
         (set! done #t)
         (collect-referenced-modules db)
         (analyse-imports)
         (print-analysis-results))))))

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