Guile: configurable warning level

3 files changed, 75 insertions, 15 deletions

diff --git a/elisp/geiser-guile.el b/elisp/geiser-guile.el
index 15c40cc..55116d3 100644
--- a/elisp/geiser-guile.el
+++ b/elisp/geiser-guile.el
@@ -63,6 +63,29 @@ If `t', Geiser will use `next-error' to jump to the error's location."
   :type 'boolean
   :group 'geiser-guile)
 
+(geiser-custom--defcustom geiser-guile-warning-level 'medium
+  "Verbosity of the warnings reported by Guile.
+
+You can choose either one of the predefined warning sets, or
+provide a list of symbols identifying the ones you want. Possible
+choices are arity-mismatch, unbound-variable, unused-variable and
+unused-toplevel. Unrecognised symbols are ignored.
+
+The predefined levels are:
+
+  - Medium: arity-mismatch, unbound-variable
+  - High: arity-mismatch, unbound-variable, unused-variable
+  - None: no warnings
+
+Changes to the value of this variable will automatically take
+effect on new REPLs. For existing ones, use the command
+\\[geiser-guile-update-warning-level]."
+  :type '(choice (const :tag "Medium (arity and unbound vars)" medium)
+                 (const :tag "High (also unused vars)" high)
+                 (const :tag "No warnings" none)
+                 (repeat :tag "Custom" symbol))
+  :group 'geiser-guile)
+
 
 ;;; REPL support:
 
@@ -189,6 +212,14 @@ This function uses `geiser-guile-init-file' if it exists."
 
 ;;; REPL startup
 
+(defun geiser-guile-update-warning-level ()
+  "Update the warning level used by the REPL.
+The new level is set using the value of `geiser-guile-warning-level'."
+  (interactive)
+  (let ((code `(:eval (ge:set-warnings ',geiser-guile-warning-level)
+                      (geiser evaluation))))
+    (geiser-eval--send/result code)))
+
 (defun geiser-guile--startup ()
   (set (make-local-variable 'compilation-error-regexp-alist)
        `((,geiser-guile--path-rx geiser-guile--resolve-file-x)
@@ -197,7 +228,8 @@ This function uses `geiser-guile-init-file' if it exists."
   (compilation-setup t)
   (font-lock-add-keywords nil
                           `((,geiser-guile--path-rx 1
-                                                    compilation-error-face))))
+                                                    compilation-error-face)))
+  (geiser-guile-update-warning-level))
 
 
 ;;; Implementation definition:
diff --git a/scheme/guile/geiser/emacs.scm b/scheme/guile/geiser/emacs.scm
index 3b6f49c..af1a052 100644
--- a/scheme/guile/geiser/emacs.scm
+++ b/scheme/guile/geiser/emacs.scm
@@ -10,9 +10,7 @@
 ;; Start date: Sun Feb 08, 2009 18:39
 
 (define-module (geiser emacs)
-  #:re-export (ge:eval
-               ge:compile
-               ge:macroexpand
+  #:re-export (ge:macroexpand
                ge:compile-file
                ge:load-file
                ge:autodoc
@@ -26,8 +24,10 @@
                ge:callers
                ge:callees
                ge:find-file)
-  #:export (ge:no-values)
-  #:export (ge:newline)
+  #:export (ge:compile
+            ge:no-values
+            ge:newline)
+  #:use-module (ice-9 match)
   #:use-module (geiser evaluation)
   #:use-module ((geiser modules) :renamer (symbol-prefix-proc 'ge:))
   #:use-module ((geiser completion) :renamer (symbol-prefix-proc 'ge:))
@@ -37,4 +37,10 @@
 (define (ge:no-values) (values))
 (define ge:newline newline)
 
+(define (ge:compile form mod)
+  (match form
+    (`((@ (geiser emacs) . ,_) . ,_) (compile/no-warns form mod))
+    (_ (compile/warns form mod))))
+
+
 ;;; emacs.scm ends here
diff --git a/scheme/guile/geiser/evaluation.scm b/scheme/guile/geiser/evaluation.scm
index aba0cfe..6b8df8f 100644
--- a/scheme/guile/geiser/evaluation.scm
+++ b/scheme/guile/geiser/evaluation.scm
@@ -10,11 +10,12 @@
 ;; Start date: Mon Mar 02, 2009 02:46
 
 (define-module (geiser evaluation)
-  #:export (ge:eval
-            ge:compile
+  #:export (compile/warns
+            compile/no-warns
             ge:macroexpand
             ge:compile-file
-            ge:load-file)
+            ge:load-file
+            ge:set-warnings)
   #:use-module (geiser modules)
   #:use-module (srfi srfi-1)
   #:use-module (language tree-il)
@@ -39,7 +40,26 @@
   (write (list (cons 'result result) (cons 'output output)))
   (newline))
 
-(define compile-opts '(#:warnings (arity-mismatch unbound-variable)))
+(define compile-opts (make-fluid))
+(define compile-file-opts (make-fluid))
+
+(define default-warnings '(arity-mismatch unbound-variable))
+(define verbose-warnings `(unused-variable ,@default-warnings))
+
+(define (ge:set-warnings wl)
+  (let* ((warns (cond ((list? wl) wl)
+                      ((symbol? wl) (case wl
+                                      ((none nil null) '())
+                                      ((medium default) default-warnings)
+                                      ((high verbose) verbose-warnings)))
+                      (else '())))
+         (fwarns (if (memq 'unused-variable warns)
+                     (cons 'unused-toplevel warns)
+                     warns)))
+    (fluid-set! compile-opts (list #:warnings warns))
+    (fluid-set! compile-file-opts (list #:warnings fwarns))))
+
+(ge:set-warnings 'none)
 
 (define (call-with-result thunk)
   (letrec* ((result #f)
@@ -50,7 +70,11 @@
                    (set! result (thunk)))))))
     (write-result result output)))
 
-(define (ge:compile form module-name)
+(define (compile/no-warns form module)
+  (with-fluids ((compile-opts '()))
+    (compile/warns form module)))
+
+(define (compile/warns form module-name)
   (let* ((module (or (find-module module-name) (current-module)))
          (ev (lambda ()
                (call-with-values
@@ -58,21 +82,19 @@
                      (let* ((o (compile form
                                         #:to 'objcode
                                         #:env module
-                                        #:opts compile-opts))
+                                        #:opts (fluid-ref compile-opts)))
                             (thunk (make-program o)))
                        (start-stack 'geiser-evaluation-stack
                                     (eval `(,thunk) module))))
                  (lambda vs (map object->string vs))))))
     (call-with-result ev)))
 
-(define ge:eval ge:compile)
-
 (define (ge:compile-file path)
   (call-with-result
    (lambda ()
      (let ((cr (compile-file path
                              #:canonicalization 'absolute
-                             #:opts compile-opts)))
+                             #:opts (fluid-ref compile-file-opts))))
        (and cr
             (list (object->string (save-module-excursion
                                    (lambda () (load-compiled cr))))))))))