[nongnu] elpa/geiser-guile 8cb76f1 045/284: Breakdown of schemeland into neat submodules.

[Philip Kaludercic]

branch: elpa/geiser-guile
commit 8cb76f1c5887d51fb96750f6dd97b8381f783fe6
Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
Commit: Jose Antonio Ortega Ruiz <jao@gnu.org>

    Breakdown of schemeland into neat submodules.
---
 geiser/completion.scm                 |  56 ++++++++++++++
 geiser/{introspection.scm => doc.scm} | 141 ++++------------------------------
 geiser/emacs.scm                      | 128 +++---------------------------
 geiser/{emacs.scm => evaluation.scm}  |  20 ++---
 geiser/modules.scm                    | 102 ++++++++++++++++++++++++
 geiser/utils.scm                      |  53 +++++++++++++
 geiser/xref.scm                       |  37 +++++++++
 7 files changed, 279 insertions(+), 258 deletions(-)

diff --git a/geiser/completion.scm b/geiser/completion.scm
new file mode 100644
index 0000000..4906368
--- /dev/null
+++ b/geiser/completion.scm
@@ -0,0 +1,56 @@
+;; completion.scm -- completing known symbols and module names
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Mon Mar 02, 2009 02:22
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Comentary:
+
+;; Completion interface with emacs.
+
+;;; Code:
+
+(define-module (geiser completion)
+  #:export (completions)
+  #:use-module (geiser utils)
+  #:use-module (ice-9 session)
+  #:use-module (ice-9 regex))
+
+(define (completions prefix . context)
+  (let ((context (and (not (null? context)) (car context)))
+        (prefix (string-append "^" (regexp-quote prefix))))
+    (append (filter (lambda (s) (string-match prefix s))
+                    (map symbol->string (local-bindings context)))
+            (sort! (map symbol->string (apropos-internal prefix)) string<?))))
+
+(define (local-bindings form)
+  (define (body f) (if (> (length f) 2) (cddr f) '()))
+  (let loop ((form form) (bindings '()))
+    (cond ((not (pair? form)) bindings)
+          ((list? (car form))
+           (loop (cdr form) (append (local-bindings (car form)) bindings)))
+          ((and (list? form) (< (length form) 2)) bindings)
+          ((memq (car form) '(define define* lambda))
+           (loop (body form) (append (pair->list (cadr form)) bindings)))
+          ((and (memq (car form) '(let let* letrec letrec*))
+                (list? (cadr form)))
+           (loop (body form) (append (map car (cadr form)) bindings)))
+          ((and (eq? 'let (car form)) (symbol? (cadr form)))
+           (loop (cons 'let (body form)) (cons (cadr form) bindings)))
+          (else (loop (cdr form) bindings)))))
+
+;;; completions.scm ends here
diff --git a/geiser/introspection.scm b/geiser/doc.scm
similarity index 57%
rename from geiser/introspection.scm
rename to geiser/doc.scm
index 900a5fa..21ede9e 100644
--- a/geiser/introspection.scm
+++ b/geiser/doc.scm
@@ -1,4 +1,4 @@
-;; introspection.scm -- name says it all
+;; doc.scm -- name says it all
 
 ;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
 
@@ -20,20 +20,16 @@
 
 ;;; Comentary:
 
-;; Procedures introspecting on scheme objects and their properties.
+;; Procedures providing documentation on scheme objects.
 
 ;;; Code:
 
-(define-module (geiser introspection)
+(define-module (geiser doc)
   #:export (autodoc
-            completions
-            symbol-location
-            symbol-documentation
-            all-modules
-            module-children
-            module-location)
+            symbol-documentation)
+  #:use-module (geiser utils)
+  #:use-module (geiser modules)
   #:use-module (system vm program)
-  #:use-module (ice-9 regex)
   #:use-module (ice-9 session)
   #:use-module (ice-9 documentation)
   #:use-module (oop goops)
@@ -55,18 +51,12 @@
 
 (define (describe-application form)
   (let* ((fun (car form))
-         (args (obj-args (symbol->obj fun))))
+         (args (obj-args (symbol->object fun))))
     (and args
          (list (cons 'signature (signature fun args))
                (cons 'position (find-position args form))
                (cons 'module (symbol-module fun))))))
 
-(define (pair->list pair)
-  (let loop ((d pair) (s '()))
-    (cond ((null? d) (reverse! s))
-          ((symbol? d) (reverse! (cons d s)))
-          (else (loop (cdr d) (cons (car d) s))))))
-
 (define (arglst args kind)
   (let ((args (assq-ref args kind)))
     (cond ((or (not args) (null? args)) '())
@@ -105,21 +95,6 @@
                          (if (null? keys) 0 (+ 1 (length keys)))
                          (if rest 2 0))))))))
 
-(define (symbol-module sym)
-  (and sym
-       (call/cc
-        (lambda (k)
-          (apropos-fold (lambda (module name var init)
-                          (if (eq? name sym) (k (module-name module)) init))
-                        #f
-                        (regexp-quote (symbol->string sym))
-                        (apropos-fold-accessible (current-module)))))))
-
-(define (symbol->obj sym)
-  (and (symbol? sym)
-       (module-defined? (current-module) sym)
-       (module-ref (current-module) sym)))
-
 (define (obj-args obj)
   (cond ((not obj) #f)
         ((or (procedure? obj) (program? obj)) (arguments obj))
@@ -178,41 +153,11 @@
           ((not (null? srcs)) (source->args (car (sort! srcs src>))))
           (else '((rest . rest))))))
 
-(define (completions prefix . context)
-  (let ((context (and (not (null? context)) (car context)))
-        (prefix (string-append "^" (regexp-quote prefix))))
-    (append (filter (lambda (s) (string-match prefix s))
-                    (map symbol->string (local-bindings context)))
-            (sort! (map symbol->string (apropos-internal prefix)) string<?))))
-
-(define (local-bindings form)
-  (define (body f) (if (> (length f) 2) (cddr f) '()))
-  (let loop ((form form) (bindings '()))
-    (cond ((not (pair? form)) bindings)
-          ((list? (car form))
-           (loop (cdr form) (append (local-bindings (car form)) bindings)))
-          ((and (list? form) (< (length form) 2)) bindings)
-          ((memq (car form) '(define define* lambda))
-           (loop (body form) (append (pair->list (cadr form)) bindings)))
-          ((and (memq (car form) '(let let* letrec letrec*))
-                (list? (cadr form)))
-           (loop (body form) (append (map car (cadr form)) bindings)))
-          ((and (eq? 'let (car form)) (symbol? (cadr form)))
-           (loop (cons 'let (body form)) (cons (cadr form) bindings)))
-          (else (loop (cdr form) bindings)))))
-
-(define (module-location name)
-  (make-location (module-filename name) #f))
-
-(define (symbol-location sym)
-  (cond ((symbol-module sym) => module-location)
-        (else '())))
-
-(define (make-location file line)
-  (list (cons 'file (if (string? file) file '()))
-        (cons 'line (if (number? line) (+ 1 line) '()))))
-
-(define module-filename (@@ (ice-9 session) module-filename))
+(define (symbol-documentation sym)
+  (let ((obj (symbol->object sym)))
+    (if obj
+        `((signature . ,(or (obj-signature sym obj) sym))
+          (docstring . ,(docstring sym obj))))))
 
 (define (docstring sym obj)
   (with-output-to-string
@@ -235,64 +180,4 @@
   (let ((args (obj-args obj)))
     (and args (signature sym args))))
 
-(define (symbol-documentation sym)
-  (let ((obj (symbol->obj sym)))
-    (if obj
-        `((signature . ,(or (obj-signature sym obj) sym))
-          (docstring . ,(docstring sym obj))))))
-
-(define (all-modules)
-  (let ((roots ((@@ (ice-9 session) root-modules))))
-    (sort! (map (lambda (m)
-                  (format "~A" (module-name m)))
-                (fold (lambda (m all)
-                        (append (all-child-modules m) all))
-                      roots
-                      roots))
-           string<?)))
-
-(define (child-modules mod)
-  (delq mod ((@@ (ice-9 session) submodules) mod)))
-
-(define (all-child-modules mod)
-  (let ((children (child-modules mod)))
-    (fold (lambda (m all)
-            (append (all-child-modules m) all))
-          children children)))
-
-(define (module-children mod-name)
-  (let* ((elts (hash-fold classify-module-object
-                          (list '() '() '())
-                          (module-obarray (maybe-module-interface mod-name))))
-         (elts (map sort-symbols! elts)))
-    (list (cons 'modules (map (lambda (m) `(,@mod-name ,m)) (car elts)))
-          (cons 'procs (cadr elts))
-          (cons 'vars (caddr elts)))))
-
-(define (sort-symbols! syms)
-  (let ((cmp (lambda (l r)
-               (string<? (symbol->string l) (symbol->string r)))))
-    (sort! syms cmp)))
-
-(define (maybe-module-interface mod-name)
-  (catch #t
-         (lambda () (resolve-interface mod-name))
-         (lambda args (resolve-module mod-name))))
-
-(define (classify-module-object name var elts)
-  (let ((obj (and (variable-bound? var)
-                  (variable-ref var))))
-    (cond ((not obj) elts)
-          ((and (module? obj) (eq? (module-kind obj) 'directory))
-           (list (cons name (car elts))
-                 (cadr elts)
-                 (caddr elts)))
-          ((or (procedure? obj) (program? obj) (macro? obj))
-           (list (car elts)
-                 (cons name (cadr elts))
-                 (caddr elts)))
-          (else (list (car elts)
-                      (cadr elts)
-                      (cons name (caddr elts)))))))
-
-;;; introspection.scm ends here
+;;; doc.scm ends here
diff --git a/geiser/emacs.scm b/geiser/emacs.scm
index f2f3d45..0c99216 100644
--- a/geiser/emacs.scm
+++ b/geiser/emacs.scm
@@ -25,128 +25,24 @@
 ;;; Code:
 
 (define-module (geiser emacs)
-  #:export (ge:eval
-            ge:compile
-            ge:macroexpand
-            ge:compile-file
-            ge:load-file)
-  #:re-export (ge:autodoc
+  #:re-export (ge:eval
+               ge:compile
+               ge:macroexpand
+               ge:compile-file
+               ge:load-file
+               ge:autodoc
                ge:completions
                ge:symbol-location
+               ge:generic-methods
                ge:symbol-documentation
                ge:all-modules
                ge:module-children
                ge:module-location)
-  #:use-module (srfi srfi-1)
-  #:use-module (system base compile)
-  #:use-module (system vm program)
-  #:use-module (ice-9 debugger utils)
-  #:use-module (ice-9 pretty-print)
-  #:use-module ((geiser introspection) :renamer (symbol-prefix-proc 'ge:)))
+  #:use-module (geiser evaluation)
+  #:use-module ((geiser modules) :renamer (symbol-prefix-proc 'ge:))
+  #:use-module ((geiser completion) :renamer (symbol-prefix-proc 'ge:))
+  #:use-module ((geiser xref) :renamer (symbol-prefix-proc 'ge:))
+  #:use-module ((geiser doc) :renamer (symbol-prefix-proc 'ge:)))
 
-(define (make-result result output)
-  (list (cons 'result result) (cons 'output output)))
-
-(define (make-error key args stack)
-  (list (cons 'error (apply parse-error (cons key args)))
-        (cons 'stack (parse-stack stack))))
-
-(define (parse-stack stack)
-  (if stack
-      (map (lambda (n) (parse-frame (stack-ref stack n)))
-           (iota (stack-length stack)))
-      '()))
-
-(define (parse-frame frame)
-  (list (cons 'frame (frame-number frame))
-        (cons 'procedure (or (and (frame-procedure? frame)
-                                  (procedure-name (frame-procedure frame)))
-                             '()))
-        (cons 'source (or (frame->source-position frame) '()))
-        (cons 'description (with-output-to-string
-                             (lambda ()
-                               (if (frame-procedure? frame)
-                                   (write-frame-short/application frame)
-                                   (write-frame-short/expression frame)))))))
-
-(define (frame->source-position frame)
-  (let ((source (if (frame-procedure? frame)
-                    (or (frame-source frame)
-                        (let ((proc (frame-procedure frame)))
-                          (and proc
-                               (procedure? proc)
-                               (procedure-source proc))))
-                    (frame-source frame))))
-    (and source
-         (cond ((string? (source-property source 'filename))
-                (list (source-property source 'filename)
-                      (+ 1 (source-property source 'line))
-                      (source-property source 'column)))
-               ((and (pair? source) (list? (cadr source)))
-                (list (caadr source)
-                      (+ 1 (caddr source))
-                      (cdddr source)))
-               (else #f)))))
-
-(define (parse-error key . args)
-  (let* ((len (length args))
-         (subr (and (> len 0) (first args)))
-         (msg (and (> len 1) (second args)))
-         (margs (and (> len 2) (third args)))
-         (rest (and (> len 3) (fourth args))))
-    (list (cons 'key key)
-          (cons 'subr (or subr '()))
-          (cons 'msg (if msg (apply format (cons #f (cons msg margs))) '()))
-          (cons 'rest (or rest '())))))
-
-(define (evaluate form module-name evaluator)
-  (let ((module (or (and (list? module-name)
-                         (resolve-module module-name))
-                    (current-module)))
-        (result #f)
-        (captured-stack #f)
-        (error #f))
-    (let ((output
-           (with-output-to-string
-             (lambda ()
-               (set! result
-                     (catch #t
-                       (lambda ()
-                         (start-stack 'id (evaluator form module)))
-                       (lambda (key . args)
-                         (set! error (make-error key args captured-stack)))
-                       (lambda (key . args)
-                         (set! captured-stack (make-stack #t 2 2)))))))))
-      (write (or error (make-result result output)))
-      (newline))))
-
-(define (eval-compile form module)
-  (save-module-excursion
-   (lambda ()
-     (set-current-module module)
-     (compile form))))
-
-(define (ge:eval form module-name)
-  (evaluate form module-name eval))
-
-(define (ge:compile form module-name)
-  (evaluate form module-name eval-compile))
-
-(define (ge:compile-file path)
-  "Compile and load file, given its full @var{path}."
-  (evaluate `(and (compile-file ,path)
-                  (load-compiled ,(compiled-file-name path)))
-            #f
-            eval))
-
-(define (ge:load-file path)
-  "Load file, given its full @var{path}."
-  (evaluate `(load ,path) #f eval))
-
-(define (ge:macroexpand form . all)
-  (let ((all (and (not (null? all)) (car all))))
-    (with-output-to-string
-      (lambda ()
-        (pretty-print ((if all macroexpand macroexpand-1) form))))))
 
 ;;; emacs.scm ends here
diff --git a/geiser/emacs.scm b/geiser/evaluation.scm
similarity index 90%
copy from geiser/emacs.scm
copy to geiser/evaluation.scm
index f2f3d45..1f3afc0 100644
--- a/geiser/emacs.scm
+++ b/geiser/evaluation.scm
@@ -1,9 +1,9 @@
-;; emacs.scm -- procedures for emacs interaction
+;; evaluation.scm -- evaluation, compilation and macro-expansion
 
 ;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
 
 ;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
-;; Start date: Sun Feb 08, 2009 18:39
+;; Start date: Mon Mar 02, 2009 02:46
 
 ;; This file is free software; you can redistribute it and/or modify
 ;; it under the terms of the GNU General Public License as published by
@@ -20,29 +20,21 @@
 
 ;;; Comentary:
 
-;; Re-exports of procedures used by Emacs.
+;; Core evaluation engine.
 
 ;;; Code:
 
-(define-module (geiser emacs)
+(define-module (geiser evaluation)
   #:export (ge:eval
             ge:compile
             ge:macroexpand
             ge:compile-file
             ge:load-file)
-  #:re-export (ge:autodoc
-               ge:completions
-               ge:symbol-location
-               ge:symbol-documentation
-               ge:all-modules
-               ge:module-children
-               ge:module-location)
   #:use-module (srfi srfi-1)
   #:use-module (system base compile)
   #:use-module (system vm program)
   #:use-module (ice-9 debugger utils)
-  #:use-module (ice-9 pretty-print)
-  #:use-module ((geiser introspection) :renamer (symbol-prefix-proc 'ge:)))
+  #:use-module (ice-9 pretty-print))
 
 (define (make-result result output)
   (list (cons 'result result) (cons 'output output)))
@@ -149,4 +141,4 @@
       (lambda ()
         (pretty-print ((if all macroexpand macroexpand-1) form))))))
 
-;;; emacs.scm ends here
+;;; evaluation.scm ends here
diff --git a/geiser/modules.scm b/geiser/modules.scm
new file mode 100644
index 0000000..13a1cdd
--- /dev/null
+++ b/geiser/modules.scm
@@ -0,0 +1,102 @@
+;; modules.scm -- module metadata
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Mon Mar 02, 2009 02:00
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Comentary:
+
+;; Utilities for accessing metadata about modules.
+
+;;; Code:
+
+(define-module (geiser modules)
+  #:export (symbol-module
+            module-filename
+            all-modules
+            module-children
+            module-location)
+  #:use-module (geiser utils)
+  #:use-module (ice-9 regex)
+  #:use-module (ice-9 session)
+  #:use-module (srfi srfi-1))
+
+(define (symbol-module sym)
+  (and sym
+       (call/cc
+        (lambda (k)
+          (apropos-fold (lambda (module name var init)
+                          (if (eq? name sym) (k (module-name module)) init))
+                        #f
+                        (regexp-quote (symbol->string sym))
+                        (apropos-fold-accessible (current-module)))))))
+
+(define (module-location name)
+  (make-location (module-filename name) #f))
+
+(define module-filename (@@ (ice-9 session) module-filename))
+
+(define (all-modules)
+  (let ((roots ((@@ (ice-9 session) root-modules))))
+    (sort! (map (lambda (m)
+                  (format "~A" (module-name m)))
+                (fold (lambda (m all)
+                        (append (all-child-modules m) all))
+                      roots
+                      roots))
+           string<?)))
+
+(define (module-children mod-name)
+  (let* ((elts (hash-fold classify-module-object
+                          (list '() '() '())
+                          (module-obarray (maybe-module-interface mod-name))))
+         (elts (map sort-symbols! elts)))
+    (list (cons 'modules (map (lambda (m) `(,@mod-name ,m)) (car elts)))
+          (cons 'procs (cadr elts))
+          (cons 'vars (caddr elts)))))
+
+(define (maybe-module-interface mod-name)
+  (catch #t
+    (lambda () (resolve-interface mod-name))
+    (lambda args (resolve-module mod-name))))
+
+(define (child-modules mod)
+  (delq mod ((@@ (ice-9 session) submodules) mod)))
+
+(define (all-child-modules mod)
+  (let ((children (child-modules mod)))
+    (fold (lambda (m all)
+            (append (all-child-modules m) all))
+          children children)))
+
+(define (classify-module-object name var elts)
+  (let ((obj (and (variable-bound? var)
+                  (variable-ref var))))
+    (cond ((not obj) elts)
+          ((and (module? obj) (eq? (module-kind obj) 'directory))
+           (list (cons name (car elts))
+                 (cadr elts)
+                 (caddr elts)))
+          ((or (procedure? obj) (program? obj) (macro? obj))
+           (list (car elts)
+                 (cons name (cadr elts))
+                 (caddr elts)))
+          (else (list (car elts)
+                      (cadr elts)
+                      (cons name (caddr elts)))))))
+
+;;; modules.scm ends here
diff --git a/geiser/utils.scm b/geiser/utils.scm
new file mode 100644
index 0000000..1aa919a
--- /dev/null
+++ b/geiser/utils.scm
@@ -0,0 +1,53 @@
+;; utils.scm -- utility functions
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Mon Mar 02, 2009 01:48
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Comentary:
+
+;; Some utilities used by other modules.
+
+;;; Code:
+
+(define-module (geiser utils)
+  #:export (make-location
+            symbol->object
+            pair->list
+            sort-symbols!))
+
+(define (symbol->object sym)
+  (and (symbol? sym)
+       (module-defined? (current-module) sym)
+       (module-ref (current-module) sym)))
+
+(define (pair->list pair)
+  (let loop ((d pair) (s '()))
+    (cond ((null? d) (reverse! s))
+          ((symbol? d) (reverse! (cons d s)))
+          (else (loop (cdr d) (cons (car d) s))))))
+
+(define (make-location file line)
+  (list (cons 'file (if (string? file) file '()))
+        (cons 'line (if (number? line) (+ 1 line) '()))))
+
+(define (sort-symbols! syms)
+  (let ((cmp (lambda (l r)
+               (string<? (symbol->string l) (symbol->string r)))))
+    (sort! syms cmp)))
+
+;;; utils.scm ends here
diff --git a/geiser/xref.scm b/geiser/xref.scm
new file mode 100644
index 0000000..2cd4d80
--- /dev/null
+++ b/geiser/xref.scm
@@ -0,0 +1,37 @@
+;; xref.scm -- cross-referencing utilities
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Mon Mar 02, 2009 02:37
+
+;; This file is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation; either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This file is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+;;; Comentary:
+
+;; Procedures to locate symbols and their xrefs.
+
+;;; Code:
+
+(define-module (geiser xref)
+  #:export (symbol-location
+            generic-methods)
+  #:use-module (geiser utils)
+  #:use-module (geiser modules))
+
+(define (symbol-location sym)
+  (cond ((symbol-module sym) => module-location)
+        (else '())))
+
+;;; xref.scm ends here