;;;; guile-shadow.scm - warn about shadowed variables in Guile code
;;;;
;;;; To the extent possible under law, the author(s) have dedicated all
;;;; copyright and related and neighboring rights to this software to
;;;; the public domain worldwide. This software is distributed without
;;;; any warranty.
;;;;
;;;; You should have received a copy of the CC0 Public Domain
;;;; Dedication along with this software. If not, see
;;;; <http://creativecommons.org/publicdomain/zero/1.0/>.

(use-modules (language tree-il)
             (language tree-il analyze)
             (ice-9 receive)
             (srfi srfi-1)
             (srfi srfi-69)
             (system base compile)
             (system base message)
             (system base language)
             (system base syntax))

;; This program is meant to warn its user about shadowed and unbound
;; variables in their Guile code. Unbound variable analysis is already
;; done by Guile's compiler on its Tree-IL (Tree Intermediate
;; Language). This is reused and a new analysis for shadowed variables
;; is implemented, along with a simple loop that compiles Scheme to
;; Tree-IL and runs the analysis.

;; Tree-IL analyses are represented by the `tree-analysis' record
;; type, however this is not exported. This extracts it from the
;; module.
(define make-tree-analysis
  (let ((module (resolve-module '(language tree-il analyze) #f #f #:ensure #f)))
    (module-ref module '%make-tree-analysis-procedure)))

;; For reporting warnings, Guile has its own system implemented in
;; (system base message). Unfortunately it cannot be easily extended,
;; therefore we have to reimplement its parts.

;; This really should be available, but it is not exported. Again,
;; same trick as above.
(define location-string
  (let ((module (resolve-module '(system base message) #f #f #:ensure #f)))
    (module-ref module 'location-string)))

(define (warn-shadow name location)
  (format (current-warning-port)
          "~A~A: warning: shadowed variable `~S'~%"
          (fluid-ref *current-warning-prefix*)
          (location-string location)
          name))

;; The actual analysis is done by traversing the Tree-IL tree. We keep
;; track of how many times a name is used in the current environment
;; by recording it in a hash table. It is very simple.

(define (name-removed tbl name loc)
  (hash-table-update!/default tbl name 1- 1))

(define (name-add tbl name loc)
  (hash-table-update!/default
   tbl
   name
   (lambda (v)
     (when (> v 0)
       (warn-shadow name loc))
     (1+ v))
   0))

(define (handle-names f tbl names loc)
  (for-each (lambda (name) (f tbl name loc)) names))

(define (dispatch-tree-il-names f tbl node locs)
  (let ((src (find pair? locs)))
    (record-case node
      ((<lambda-case> req opt)
       (handle-names f tbl req src)
       (when opt
         (handle-names f tbl opt src)))
      ((<let> names)
       (handle-names f tbl names src))
      ((<letrec> names)
       (handle-names f tbl names src))
      ((<fix> names)
       (handle-names f tbl names src))
      (else node))
    tbl))

;; A Tree-IL analysis is made of four elements:
;; 1. A procedure invoked upon entering a node.
;; 2. A procedure invoked after every children of the node has been visited.
;; 3. A procedure invoked after every node has been visited.
;; 4. An initial value.
(define shadowed-variable-analysis
  (make-tree-analysis
   (lambda (node tbl env locs)
     (dispatch-tree-il-names name-add tbl node locs))
   (lambda (node tbl env locs)
     (dispatch-tree-il-names name-removed tbl node locs))
   (lambda (tbl env)
     (for-each (lambda (k) (hash-table-delete! tbl k))
               (hash-table-keys tbl))
     #t)
   (make-hash-table)))

;; Main loop that reads in Scheme expressions, compiles them to
;; Tree-IL and when it is all done, runs the analysers on it.

(define (parse-compile-analyze)
  (let ((compiler (compute-compiler
                   'scheme
                   'tree-il
                   (default-optimization-level)
                   (default-warning-level)
                   '())))
    (let loop ((x (read))
               (exps '())
               (env (default-environment 'scheme)))
      (if (eof-object? x)
          (let ((tree ((language-joiner (lookup-language 'tree-il)) (reverse exps) env)))
            (with-fluids ((*current-warning-prefix* ">>> "))
              (analyze-tree (list shadowed-variable-analysis
                                  shadowed-toplevel-analysis
                                  unbound-variable-analysis)
                            tree
                            env)))
          (receive (exp env cenv) (compiler x env)
            (loop (read) (cons exp exps) cenv))))))

(if (pair? (cdr (command-line)))
    (for-each
     (lambda (file)
       (with-input-from-file file
         parse-compile-analyze))
     (cdr (command-line)))
    (parse-compile-analyze))

;;; Commentary
;;
;; Source locations in the warnings point to the start of the
;; expression, not the actual offending names. As far as I can tell,
;; this is the closest position to the error that is saved while
;; reading and expanding the Scheme expressions.
;;
;; With more accurate source positions, highlighting the shadowed
;; variable could be helpful too.
;;
;; This program was written for Scheme but since the actual analysis
;; is done on Tree-IL, therefore any language that compiles to it
;; should work with minimal changes (changing the reader and the input
;; language of `compute-compiler').
;;
;; It would be great if `guild' had a command that compiles code to
;; Tree-IL without producing an output file. This way the existing
;; analyses could be used for easy diagnosis. It would be even better
;; if there was a way to load extra modules that extended the
;; available analyses.