diff options
Diffstat (limited to 'geiser')
| -rw-r--r-- | geiser/completion.scm | 56 | ||||
| -rw-r--r-- | geiser/doc.scm (renamed from geiser/introspection.scm) | 141 | ||||
| -rw-r--r-- | geiser/emacs.scm | 128 | ||||
| -rw-r--r-- | geiser/evaluation.scm | 144 | ||||
| -rw-r--r-- | geiser/modules.scm | 102 | ||||
| -rw-r--r-- | geiser/utils.scm | 53 | ||||
| -rw-r--r-- | geiser/xref.scm | 37 |
7 files changed, 417 insertions, 244 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 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/evaluation.scm b/geiser/evaluation.scm new file mode 100644 index 0000000..1f3afc0 --- /dev/null +++ b/geiser/evaluation.scm @@ -0,0 +1,144 @@ +;; evaluation.scm -- evaluation, compilation and macro-expansion + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; 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 +;; 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: + +;; Core evaluation engine. + +;;; Code: + +(define-module (geiser evaluation) + #:export (ge:eval + ge:compile + ge:macroexpand + ge:compile-file + ge:load-file) + #: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)) + +(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)))))) + +;;; 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 |