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