From 78152318f5e6fb8ad315bd72a8b9257ec4b91b4b Mon Sep 17 00:00:00 2001
From: Jose Antonio Ortega Ruiz <jao@gnu.org>
Date: Sun, 3 May 2009 03:19:43 +0200
Subject: Hopefully harmless refactoring.
---
scheme/plt/geiser/eval.ss | 22 +++++--------------
scheme/plt/geiser/locations.ss | 13 ++++++++---
scheme/plt/geiser/utils.ss | 49 ++++++++++++++++++++++++++++++++++++++++++
3 files changed, 64 insertions(+), 20 deletions(-)
create mode 100644 scheme/plt/geiser/utils.ss
(limited to 'scheme')
diff --git a/scheme/plt/geiser/eval.ss b/scheme/plt/geiser/eval.ss
index 090b517..9c6534e 100644
--- a/scheme/plt/geiser/eval.ss
+++ b/scheme/plt/geiser/eval.ss
@@ -33,7 +33,7 @@
macroexpand
make-repl-reader)
-(require scheme/enter srfi/13)
+(require scheme/enter geiser/utils)
(define last-result (void))
(define nowhere (open-output-nowhere))
@@ -66,21 +66,8 @@
(and (resolved-module-path? rmp)
(resolved-module-path-name rmp))))
-(define (namespace->module-name ns)
- (let ((path (namespace->module-path-name ns)))
- (if (not path)
- "<top>"
- (let* ((path (path->string path))
- (cpaths (map path->string (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 __) basename))
- (regexp-replace "\\.[^./]*$" real-path ""))))))
+(define namespace->module-name
+ (compose module-path-name->name namespace->module-path-name))
(define last-namespace (make-parameter (current-namespace)))
@@ -111,7 +98,8 @@
(set-last-result
(string-append (with-output-to-string
(lambda ()
- (load-module (ensure-spec file) (current-output-port))))
+ (load-module (ensure-spec file)
+ (current-output-port))))
"done."))
(load-module (and (path? current-path)
(ensure-spec (path->string current-path))))))
diff --git a/scheme/plt/geiser/locations.ss b/scheme/plt/geiser/locations.ss
index 80040f9..1b13e8f 100644
--- a/scheme/plt/geiser/locations.ss
+++ b/scheme/plt/geiser/locations.ss
@@ -26,16 +26,23 @@
#lang scheme
-(provide symbol-location)
+(provide symbol-location
+ symbol-module-path-name
+ symbol->module-name)
-(define (%symbol-location sym)
+(require geiser/utils)
+
+(define (symbol-module-path-name sym)
(let ([binding (identifier-binding sym)])
(and (list? binding)
(resolved-module-path-name
(module-path-index-resolve (car binding))))))
(define (symbol-location sym)
- (let ((file (%symbol-location (namespace-symbol->identifier sym))))
+ (let ((file (symbol-module-path-name (namespace-symbol->identifier sym))))
(list (cons 'file (if (path? file) (path->string file) '())))))
+(define symbol->module-name
+ (compose module-path-name->name symbol-module-path-name))
+
;;; locations.ss ends here
diff --git a/scheme/plt/geiser/utils.ss b/scheme/plt/geiser/utils.ss
new file mode 100644
index 0000000..9a774df
--- /dev/null
+++ b/scheme/plt/geiser/utils.ss
@@ -0,0 +1,49 @@
+;; utils.ss -- generic utilities
+
+;; Copyright (C) 2009 Jose Antonio Ortega Ruiz
+
+;; Author: Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sun May 03, 2009 03:09
+
+;; 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:
+
+;; Utility procedures
+
+;;; Code:
+
+#lang scheme
+
+(provide module-path-name->name)
+
+(require srfi/13)
+
+(define (module-path-name->name path)
+ (if (path? path)
+ (let* ((path (path->string path))
+ (cpaths (map path->string (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 __) basename))
+ (regexp-replace "\\.[^./]*$" real-path "")))
+ "<top>"))
+
+
+;;; utils.ss ends here
--
cgit v1.2.3