diff options
Diffstat (limited to 'scheme/plt/geiser')
| -rw-r--r-- | scheme/plt/geiser/autodoc.ss | 2 | ||||
| -rw-r--r-- | scheme/plt/geiser/eval.ss | 38 | ||||
| -rw-r--r-- | scheme/plt/geiser/locations.ss | 17 | ||||
| -rw-r--r-- | scheme/plt/geiser/modules.ss | 87 | ||||
| -rw-r--r-- | scheme/plt/geiser/utils.ss | 24 |
5 files changed, 107 insertions, 61 deletions
diff --git a/scheme/plt/geiser/autodoc.ss b/scheme/plt/geiser/autodoc.ss index d7f3a0e..423f52e 100644 --- a/scheme/plt/geiser/autodoc.ss +++ b/scheme/plt/geiser/autodoc.ss @@ -24,7 +24,7 @@ (provide autodoc update-module-cache) -(require geiser/utils geiser/locations) +(require geiser/utils geiser/modules geiser/locations) (define (autodoc form) (cond ((null? form) #f) diff --git a/scheme/plt/geiser/eval.ss b/scheme/plt/geiser/eval.ss index 694802a..56a321e 100644 --- a/scheme/plt/geiser/eval.ss +++ b/scheme/plt/geiser/eval.ss @@ -33,38 +33,9 @@ macroexpand make-repl-reader) -(require scheme/enter geiser/utils geiser/autodoc) +(require scheme/enter geiser/modules geiser/autodoc) (define last-result (void)) -(define nowhere (open-output-nowhere)) - -(define (ensure-spec spec) - (cond ((symbol? spec) spec) - ((not (string? spec)) #f) - ((not (file-exists? spec)) #f) - ((absolute-path? spec) `(file ,spec)) - (else spec))) - -(define (load-module spec . port) - (parameterize ((current-error-port (if (null? port) nowhere (car port)))) - (eval #`(enter! #,spec)))) - -(define (ensure-namespace mod-spec) - (letrec ((spec (ensure-spec mod-spec)) - (handler (lambda (e) - (load-module spec) - (enter! #f) - (module->namespace spec)))) - (if spec - (with-handlers ((exn:fail:contract? handler)) - (module->namespace spec)) - (current-namespace)))) - -(define (namespace->module-path-name ns) - (let ((rmp (variable-reference->resolved-module-path - (eval '(#%variable-reference) ns)))) - (and (resolved-module-path? rmp) - (resolved-module-path-name rmp)))) (define namespace->module-name (compose module-path-name->name namespace->module-path-name)) @@ -87,7 +58,7 @@ (with-handlers ((exn? set-last-error)) (update-module-cache spec form) (call-with-values - (lambda () (eval form (ensure-namespace spec))) + (lambda () (eval form (module-spec->namespace spec))) set-last-result)) last-result) @@ -100,11 +71,10 @@ (set-last-result (string-append (with-output-to-string (lambda () - (load-module (ensure-spec file) - (current-output-port)))) + (load-module file (current-output-port)))) "done.")) (load-module (and (path? current-path) - (ensure-spec (path->string current-path)))))) + (path->string current-path))))) last-result) (define compile-file load-file) diff --git a/scheme/plt/geiser/locations.ss b/scheme/plt/geiser/locations.ss index d1c5cb7..87a643d 100644 --- a/scheme/plt/geiser/locations.ss +++ b/scheme/plt/geiser/locations.ss @@ -28,10 +28,11 @@ (provide symbol-location symbol-location* + module-location symbol-module-name symbol-module-path-name) -(require geiser/utils) +(require geiser/utils geiser/modules) (define (symbol-location* sym) (let* ((id (namespace-symbol->identifier sym)) @@ -43,16 +44,26 @@ (module-path-index-resolve (car binding)))) (cons sym #f)))) +(define (make-location name path line) + (list (cons 'name name) + (cons 'file (if (path? path) (path->string path) '())) + (cons 'line (or line '())))) + (define (symbol-location sym) (let* ((loc (symbol-location* sym)) (name (car loc)) (path (cdr loc))) - (list (cons 'name name) - (cons 'file (if (path? path) (path->string path) '()))))) + (if path + (make-location name path #f) + (module-location sym)))) (define symbol-module-path-name (compose cdr symbol-location*)) (define symbol-module-name (compose module-path-name->name symbol-module-path-name)) +(define (module-location sym) + (make-location sym (module-spec->path-name sym) 1)) + + ;;; locations.ss ends here diff --git a/scheme/plt/geiser/modules.ss b/scheme/plt/geiser/modules.ss new file mode 100644 index 0000000..3bed19e --- /dev/null +++ b/scheme/plt/geiser/modules.ss @@ -0,0 +1,87 @@ +;; modules.ss -- module metadata + +;; Copyright (C) 2009 Jose Antonio Ortega Ruiz + +;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org> +;; Start date: Wed May 06, 2009 02:35 + +;; 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/>. + +;;; Code: + +#lang scheme + +(provide load-module + module-spec->namespace + namespace->module-path-name + module-path-name->name + module-spec->path-name) + +(require srfi/13 scheme/enter) + +(define nowhere (open-output-nowhere)) + +(define (ensure-module-spec spec) + (cond ((symbol? spec) spec) + ((not (string? spec)) #f) + ((not (file-exists? spec)) #f) + ((absolute-path? spec) `(file ,spec)) + (else spec))) + +(define (module-spec->namespace mod-spec) + (letrec ((spec (ensure-module-spec mod-spec)) + (handler (lambda (e) + (load-module spec) + (enter! #f) + (module->namespace spec)))) + (if spec + (with-handlers ((exn:fail:contract? handler)) + (module->namespace spec)) + (current-namespace)))) + +(define (load-module spec . port) + (parameterize ((current-error-port (if (null? port) nowhere (car port)))) + (eval #`(enter! #,(ensure-module-spec spec))))) + +(define (namespace->module-path-name ns) + (let ((rmp (variable-reference->resolved-module-path + (eval '(#%variable-reference) ns)))) + (and (resolved-module-path? rmp) + (resolved-module-path-name rmp)))) + +(define (module-spec->path-name spec) + (with-handlers ((exn? (lambda (_) #f))) + (let ((ns (module->namespace (ensure-module-spec spec)))) + (namespace->module-path-name (eval '(current-namespace) ns))))) + +(define (module-path-name->name path) + (cond ((path? path) + (let* ((path (path->string path)) + (cpaths (map (compose path->string path->directory-path) + (current-library-collection-paths))) + (prefix-len (lambda (p) + (let ((pl (string-length p))) + (if (= pl (string-prefix-length p path)) pl 0)))) + (lens (map prefix-len cpaths)) + (real-path (substring path (apply max lens)))) + (if (absolute-path? real-path) + (call-with-values (lambda () (split-path path)) + (lambda (_ basename __) (path->string basename))) + (regexp-replace "\\.[^./]*$" real-path "")))) + ((eq? path '#%kernel) "(kernel)") + ((string? path) path) + ((symbol? path) (symbol->string path)) + (else "<top>"))) + +;;; modules.ss ends here diff --git a/scheme/plt/geiser/utils.ss b/scheme/plt/geiser/utils.ss index 557cf26..84c6964 100644 --- a/scheme/plt/geiser/utils.ss +++ b/scheme/plt/geiser/utils.ss @@ -26,32 +26,10 @@ #lang scheme -(provide module-path-name->name - pair->list +(provide pair->list keyword->symbol symbol->keyword) -(require srfi/13) - -(define (module-path-name->name path) - (cond ((path? path) - (let* ((path (path->string path)) - (cpaths (map (compose path->string path->directory-path) - (current-library-collection-paths))) - (prefix-len (lambda (p) - (let ((pl (string-length p))) - (if (= pl (string-prefix-length p path)) pl 0)))) - (lens (map prefix-len cpaths)) - (real-path (substring path (apply max lens)))) - (if (absolute-path? real-path) - (call-with-values (lambda () (split-path path)) - (lambda (_ basename __) (path->string basename))) - (regexp-replace "\\.[^./]*$" real-path "")))) - ((eq? path '#%kernel) "(kernel)") - ((string? path) path) - ((symbol? path) (symbol->string path)) - (else "<top>"))) - (define (pair->list pair) (let loop ((d pair) (s '())) (cond ((null? d) (reverse s)) |