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

(declare
  (module (beaker)))

(define (configure-compiler-extension)
  (import (chicken compiler user-pass)
          (chicken eval)
          (chicken internal)
          (chicken memory representation)
          (chicken plist)
          (chicken port)
          (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 (write-length x)
    (string-length (with-output-to-string (lambda () (write x)))))

  (define (fragment width depth x)
    (let ((w 0))
      (let loop ((x x) (d 0))
        (cond ((vector? x)
               (list->vector (loop (vector->list x) d)))
              ((symbol? x)
               (string->symbol (loop (symbol->string x) d)))
              ((string? x)
               (let ((n (string-length x)))
                 (if (< (+ w n) width)
                     (begin (set! w (+ (write-length x) w)) x)
                     (string-append (substring x 0 (min (+ w n) width)) "..."))))
              ((atom? x)
               (begin (set! w (+ (write-length x) w)) x))
              (else
               (let ((a (loop (car x) (add1 d))))
                 (set! w (add1 w))
                 (if (and (pair? (cdr x))
                          (or (> w width)
                              (> d depth)))
                     (list a '...)
                     (cons a (loop (cdr x) d)))))))))

  (define (expression-contains-identifier? x id)
    (cond ((symbol? x)
           (equal? x id))
          ((pair? x)
           (or (expression-contains-identifier? (car x) id)
               (expression-contains-identifier? (cdr x) id)))
          (else #f)))

  (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-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 '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)
          (write (cons* (symbol->string loc) severity (car warning) (fragment 64 5 (list (cdr warning)))))
          (newline))))))

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