From 19a5daaec41aea330c081bd0b1fe228f7a5bb998 Mon Sep 17 00:00:00 2001
From: Lockywolf <lockywolf@gmail.com>
Date: Fri, 9 Aug 2019 01:51:14 +0800
Subject: Add a first version of geiser:symbol-location for local files.

---
 scheme/chibi/geiser/geiser.scm | 132 ++++++++++++++++++++++++++++++++++++-----
 scheme/chibi/geiser/geiser.sld |   7 ++-
 2 files changed, 123 insertions(+), 16 deletions(-)

(limited to 'scheme/chibi/geiser')

diff --git a/scheme/chibi/geiser/geiser.scm b/scheme/chibi/geiser/geiser.scm
index 9218646..a147b36 100644
--- a/scheme/chibi/geiser/geiser.scm
+++ b/scheme/chibi/geiser/geiser.scm
@@ -19,6 +19,11 @@
     (write form out)
     (get-output-string out)))
 
+(define (geiser:write/ss-to-string form)
+  (let ((out (open-output-string)))
+    (write/ss form out)
+    (get-output-string out)))
+
 ;;> Evaluate a \var{form} in the namespace of the \var{module}.
 ;;> The meaning of \var{rest} is unknown.
 ;;> Return the alist with the first field, \scheme{result}, holds
@@ -30,15 +35,20 @@
   rest
   (guard (err (else (write `((result ,(show #f err))))))
     (let* ((output (open-output-string))
-          (result (parameterize ((current-output-port output))
-		    (if module
-                      (let ((mod (module-env (find-module module))))
-                        (eval form mod))
-                      (eval form)))))
+	   (result (parameterize ((current-output-port output))
+		     (if module
+			 (let ((mod (module-env (find-module module))))
+			   (eval form mod))
+			 (eval form))
+		     )
+		   ))
       (write `((result ,(write-to-string result))
                (output . ,(get-output-string output))))))
   (values))
 
+
+; (display "debug:Hello\n")
+
 (define (geiser:module-completions prefix . rest)
   ;; (available-modules) walks the directory tree and is too slow
   (let ((modules (map car *modules*)))
@@ -107,12 +117,104 @@
 ;;> \var{line} is the line number starting from 0 (scheme way).
 
 (define (make-location file line)
-  (list (cons "file" (if (string? file) file '()))
-        (cons "line" (if (number? line) (+ 1 line) '()))))
-
-
-;TODO: (define (geiser:symbol-location) ; implement this method in order to make
+  (list (cons "file"
+	      (if (string? file)
+		  (path-resolve
+		   file
+		   (current-directory))
+		  '()))
+        (cons "line" (if (number? line) (+ 1 line) '())))
+)
+
+
+;TODO: (define (geiser:symbol-location)
+; implement this method in order to make
 ; xref work better in Chibi. For reference, see [[geiser:module-location]]
+; (analyze-module (caar (modules-exporting-identifier 'symbol-in-question)))
+;(module-ast (analyze-module (caar (modules-exporting-identifier 'ckind))))
+(define (geiser:symbol-location symbol-in-question . rest)
+  (let* (
+	 (result (tree-walker
+		 (module-ast
+		  (analyze-module
+		   (caar
+		    (modules-exporting-identifier
+		     symbol-in-question))))
+		 symbol-in-question))
+	 (location
+	  (make-location
+	   (car result)
+	   (- (cdr result) 1))) ; Ehh... line numbering in 'make-location starts from 0
+	 )
+    location
+    )
+)
+
+(define (tree-walker node . symbol-in-question)
+; The reason this function used  a (let), not a (begin) is that (begin)
+; for some reason does not allow (display)s inside. It 
+; works in xfce4-terminal, but not here. I decided not to
+; debug it, since (do) "just worked". TODO.
+  
+  (if (pair? node)
+	(let ((result
+	       (tree-walker
+		(car node)
+		(car symbol-in-question)))
+	      )
+	  (if result
+		result
+		(tree-walker (cdr node) (car symbol-in-question))
+	      )
+	  )
+      (let () ; we have leaf
+	(if (set? node)
+	    (if (equal? (ref-name (set-var node)) (car symbol-in-question))
+		(let ((thingy (set-value node)))
+		  (if (lambda? thingy)
+		      (lambda->lcons thingy)
+		      (set-node->lcons/dirty-trick node)
+		      )
+		  )
+		#f
+		)
+	    #f
+	    )
+	)
+      )
+  )
+
+(define (lambda->lcons thingy)
+  (let* ((l-source (lambda-source thingy))
+	 (l-location
+	  (cons
+	   (car l-source)
+	   (cdr l-source))))
+    l-location
+    ))
+
+(define (set-node->lcons/dirty-trick node)
+  (let* ((exam2 (geiser:write/ss-to-string node))
+	 (strl (string-length exam2))
+	 (l-matches
+	  (regexp-search
+	   '(: "(\""
+	       (-> filename (*? graphic) )
+	       "\" . "
+	       (-> lineno (+ num) )
+	       ")}")
+	   exam2 ))
+	 (l-filename
+	  (regexp-match-submatch l-matches 'filename))
+	 (l-lineno
+	  (string->number
+	   (regexp-match-submatch l-matches 'lineno)))
+	 (l-location
+	  (cons l-filename l-lineno)))
+    l-location))
+
+;(geiser:symbol-location 'run-application)
+
 
 
 ;;> A function to find the file where the symbol
@@ -120,9 +222,11 @@
 
 (define (geiser:module-location symbol-representing-module)
   (make-location
-   (string-append (current-directory) "/"
-    (find-module-file
+   (find-module-file
     (module-name->file
      (module-name
-      (find-module symbol-representing-module)))))
-   0 ) )
+      (find-module symbol-representing-module))))
+   0 )
+)
+
+
diff --git a/scheme/chibi/geiser/geiser.sld b/scheme/chibi/geiser/geiser.sld
index 8e43fb8..86f871a 100644
--- a/scheme/chibi/geiser/geiser.sld
+++ b/scheme/chibi/geiser/geiser.sld
@@ -5,7 +5,7 @@
           geiser:autodoc
           geiser:module-completions
           geiser:no-values
-;TODO:	  geiser:symbol-location ; implement this interface in [[file://./geiser.scm#geiser:symbol-location]] in order to make proper cross-referencing working.
+	  geiser:symbol-location ; implement this interface in [[file://./geiser.scm#geiser:symbol-location]] in order to make proper cross-referencing working.
 	  geiser:module-location
           geiser:newline)
   (import
@@ -13,10 +13,13 @@
     (chibi modules)
     (chibi)
     (chibi filesystem)
+    (chibi pathname)
     (meta)
     (chibi ast)
     (chibi string)
     (srfi 1)
     (srfi 95)
-    (chibi show))
+    (srfi 38)
+    (chibi show)
+    (srfi 115))
   (include "geiser.scm"))
-- 
cgit v1.2.3