[nongnu] elpa/geiser-chicken fb9ddca 066/102: Chicken 5 works with Geiser, many features removed

[Philip Kaludercic]

branch: elpa/geiser-chicken
commit fb9ddca69a8a80ef30af97d077854759606faafc
Author: Dan Leslie <dan@ironoxide.ca>
Commit: Jose Antonio Ortega Ruiz <jao@gnu.org>

    Chicken 5 works with Geiser, many features removed
---
 geiser/chicken5.scm | 401 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 401 insertions(+)

diff --git a/geiser/chicken5.scm b/geiser/chicken5.scm
new file mode 100644
index 0000000..f5f0c30
--- /dev/null
+++ b/geiser/chicken5.scm
@@ -0,0 +1,401 @@
+;; -*- geiser-scheme-implementation: 'chicken
+
+;; Copyright (C) 2018 Daniel J Leslie
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the Modified BSD License. You should
+;; have received a copy of the license along with this program. If
+;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
+
+(module geiser
+  (geiser-eval
+   geiser-no-values
+   geiser-newline
+   geiser-start-server
+   geiser-completions
+   geiser-autodoc
+   geiser-object-signature
+   geiser-symbol-location
+   geiser-symbol-documentation
+   geiser-find-file
+   geiser-add-to-load-path
+   geiser-load-file
+   geiser-compile-file
+   geiser-compile
+   geiser-module-exports
+   geiser-module-path
+   geiser-module-location
+   geiser-module-completions
+   geiser-macroexpand
+   geiser-chicken-use-debug-log
+   geiser-chicken-load-paths)
+
+  (import
+    scheme
+    apropos
+    srfi-1
+    srfi-18
+    (chicken base)
+    (chicken tcp)
+    (chicken file)
+    (chicken file posix)
+    (chicken format)
+    (chicken condition)
+    (chicken port)
+    (chicken string)
+    (chicken repl)
+    (chicken syntax))
+
+
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;; Utilities
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define geiser-chicken-use-debug-log (make-parameter #f))
+
+  (define empty-symbol (string->symbol ""))
+
+  (define (symbol-information-list partial-string)
+    (map (lambda (lst)
+          (let* ((module (if (eq? empty-symbol (caar lst)) #f (caar lst)))
+                 (name (cdar lst)))
+            (append (list name module) (cdr lst))))
+        (apropos-information-list partial-string #:macros? #t)))
+  
+  (define debug-log (make-parameter #f))
+  (define (write-to-log form)
+    (when (geiser-chicken-use-debug-log)
+      (when (not (debug-log))
+       (debug-log (file-open "geiser.log" (+ open/wronly open/append open/text 
open/creat)))
+       (set-file-position! (debug-log) 0 seek/end))
+      (file-write (debug-log) (with-all-output-to-string (lambda () (write 
form) (newline))))
+      (file-write (debug-log) "\n")))
+
+  (define (string-has-prefix? s prefix)
+    (cond
+     ((= 0 (string-length prefix)) #t)
+     ((= 0 (string-length s)) #f)
+     ((eq? (string-ref s 0) (string-ref prefix 0))
+      (string-has-prefix? (substring s 1) (substring prefix 1)))
+     (else #f)))
+  
+  ;; This really should be a chicken library function
+  (define (write-exception exn)
+    (define (write-call-entry call)
+      (let ((type (vector-ref call 0))
+            (line (vector-ref call 1)))
+        (cond
+         ((equal? type "<syntax>")
+          (display (string-append type " ")) (write line) (newline))
+         ((equal? type "<eval>")
+          (display (string-append type "   ")) (write line) (newline)))))
+
+    (display (format "Error: (~s) ~s: ~s"
+                     ((condition-property-accessor 'exn 'location) exn)
+                     ((condition-property-accessor 'exn 'message) exn)
+                     ((condition-property-accessor 'exn 'arguments) exn)))
+    (newline)
+    (display "Call history: ") (newline)
+    (map write-call-entry ((condition-property-accessor 'exn 'call-chain) exn))
+    (newline))
+
+  ;; And this should be a chicken library function as well
+  (define (with-all-output-to-string thunk)
+    (with-output-to-string
+      (lambda ()
+        (with-error-output-to-port
+         (current-output-port)
+         thunk))))
+
+  (define (maybe-call func val)
+    (if val (func val) #f))
+
+  ;; Wraps output from geiser functions
+  (define (call-with-result module thunk)
+    (let* ((result (if #f #f))
+           (output (if #f #f)))
+
+      (set! output
+            (handle-exceptions exn
+             (with-all-output-to-string
+              (lambda () (write-exception exn)))
+             (with-all-output-to-string
+              (lambda ()
+                (call-with-values thunk (lambda v (set! result v)))))))
+
+      (set! result
+        (cond
+         ((list? result)
+          (map (lambda (v) (with-output-to-string (lambda () (write v)))) 
result))
+         ((eq? result (if #f #t))
+          (list output))
+         (else
+          (list (with-output-to-string (lambda () (write result)))))))
+
+      (let ((out-form
+             `((result ,@result)
+               (output . ,output))))
+        (write out-form)
+       (write-to-log '[[RESPONSE]])
+        (write-to-log out-form))
+
+      (newline)))
+
+  (define (read* str)
+    (with-input-from-string str (lambda () (read))))
+  
+  (define (eval* str)
+    (cond
+     ((symbol? str) (eval str))
+     ((string? str) (eval (read* str)))
+     (else #f)))
+  
+  (define (fmt node)
+    (let* ((mod (cadr node))
+          (sym (car node))
+          (rest (cddr node))
+          (type (if (or (list? rest) (pair? rest)) (car rest) rest)))
+      (cond
+       ((equal? 'macro type)
+       `(,sym ("args" (("required" <macro>)
+                       ("optional" ...)
+                       ("key")))
+              ("module")))
+       ((or (equal? 'variable type)
+           (equal? 'constant type))
+       `(,sym ("value" . ,(eval* sym))))
+       (else
+       (let ((reqs '())
+             (opts '())
+             (keys '())
+             (args (if (or (list? rest) (pair? rest)) (cdr rest) '())))
+
+         (define (collect-args args #!key (reqs? #t) (opts? #f) (keys? #f))
+           (when (not (null? args))
+             (cond
+              ((or (pair? args) (list? args))
+               (cond
+                ((eq? '#!key (car args))
+                 (collect-args (cdr args) reqs?: #f opts?: #f keys?: #t))
+                ((eq? '#!optional (car args))
+                 (collect-args (cdr args) reqs?: #f opts?: #t keys?: #f))
+                (else
+                 (begin
+                   (cond
+                    (reqs?
+                     (set! reqs (append reqs (list (car args)))))
+                    (opts?
+                     (set! opts (append opts (list (cons (caar args) (cdar 
args))))))
+                    (keys?
+                     (set! keys (append keys (list (cons (caar args) (cdar 
args)))))))
+                   (collect-args (cdr args))))))
+              (else
+               (set! opts (list args '...))))))
+
+         (collect-args args)
+
+         `(,sym ("args" (("required" ,@reqs)
+                         ("optional" ,@opts)
+                         ("key" ,@keys)))
+                ("module")))))))
+
+  ;; Builds a signature list from an identifier
+  (define (find-signatures sym)
+    (let ((result (symbol-information-list sym)))
+      (map fmt result)))
+  
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Geiser core functions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; Basically all non-core functions pass through geiser-eval
+
+  (define (form-has-safe-geiser? form)
+    (any (cut eq? (car form) <>)
+        '(geiser-no-values geiser-newline geiser-completions
+          geiser-autodoc geiser-object-signature geiser-symbol-location
+          geiser-symbol-documentation geiser-module-exports
+          geiser-module-path geiser-module-location
+          geiser-module-completions geiser-chicken-use-debug-log)))
+    
+  (define (form-has-any-geiser? form)
+    (string-has-prefix? (->string (car form)) "geiser-"))
+
+  (define (form-defines-any-module? form)
+    (or
+     ;; Geiser seems to send buffers as (begin ..buffer contents..)
+     (and (eq? (car form) 'begin)
+         (form-defines-any-module? (cadr form)))
+     (any (cut eq? (car form) <>)
+         '(module define-library))))
+
+  (define (geiser-eval module form . rest)
+    (when (and module (not (symbol? module)))
+      (error "Module should be a symbol"))
+    
+    ;; All calls start at toplevel
+    (let* ((is-safe-geiser? (form-has-safe-geiser? form))
+          (host-module (and (not is-safe-geiser?)
+                            (not (form-has-any-geiser? form))
+                            (not (form-defines-any-module? form))
+                            module))
+          (thunk (lambda () (eval form))))
+
+      (write-to-log `[[REQUEST host-module: ,host-module]])
+      (write-to-log form)
+
+      (if is-safe-geiser?
+         (call-with-result #f thunk)
+         (call-with-result host-module thunk))))
+
+  ;; Load a file
+
+  (define (geiser-load-file file)
+    (let* ((file (if (symbol? file) (symbol->string file) file))
+           (found-file (geiser-find-file file)))
+      (call-with-result #f
+       (lambda ()
+         (when found-file
+           (load found-file))))))
+
+  ;; The no-values identity
+
+  (define (geiser-no-values)
+    (values))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Miscellaneous
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; Invoke a newline
+
+  (define (geiser-newline . rest)
+    (newline))
+
+  ;; Spawn a server for remote repl access
+
+  (define (geiser-start-server . rest)
+    (let* ((listener (tcp-listen 0))
+           (port (tcp-listener-port listener)))
+      (define (remote-repl)
+        (receive (in out) (tcp-accept listener)
+          (current-input-port in)
+          (current-output-port out)
+          (current-error-port out)
+
+          (repl)))
+
+      (thread-start! (make-thread remote-repl))
+
+      (write-to-log `(geiser-start-server . ,rest))
+      (write-to-log `(port ,port))
+
+      (write `(port ,port))
+      (newline)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Completions, Autodoc and Signature
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (geiser-completions prefix . rest)
+    (let ((prefix (->string prefix)))
+      (filter (cut string-has-prefix? <> prefix)
+             (map ->string (map car (symbol-information-list prefix))))))
+
+  (define (geiser-module-completions prefix . rest)
+    '())
+  
+  (define (geiser-autodoc ids . rest)
+    (cond
+     ((null? ids) '())
+     ((not (list? ids))
+      (geiser-autodoc (list ids)))
+     (else 
+      (let ((details (find-signatures (car ids))))
+       (if (null? details)
+           (geiser-autodoc (cdr ids))
+           details)))))
+  
+  (define (geiser-object-signature name object . rest)
+    (let* ((sig (geiser-autodoc `(,name))))
+      (if (null? sig) '() (car sig))))
+
+    ;; TODO: Divine some way to support this functionality
+
+  (define (geiser-symbol-location symbol . rest)
+    '(("file") ("line")))
+
+  (define (geiser-symbol-documentation symbol . rest)
+    (let* ((sig (find-signatures symbol)))
+      `(("signature" ,@(car sig))
+        ("docstring" . ""))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; File and Buffer Operations
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define geiser-chicken-load-paths (make-parameter '("" ".")))
+
+  (define (geiser-find-file file . rest)
+    (when file
+      (let ((paths (geiser-chicken-load-paths)))
+       (define (try-find file paths)
+         (cond
+          ((null? paths) #f)
+          ((file-exists? (string-append (car paths) file))
+           (string-append (car paths) file))
+          (else (try-find file (cdr paths)))))
+       (try-find file paths))))
+
+  (define (geiser-add-to-load-path directory . rest)
+    (let* ((directory (if (symbol? directory)
+                          (symbol->string directory)
+                          directory))
+           (directory (if (not (equal? #\/ (string-ref directory (- 
(string-length directory)))))
+                          (string-append directory "/")
+                          directory)))
+      (call-with-result #f
+       (lambda ()
+         (when (directory-exists? directory)
+           (geiser-chicken-load-paths (cons directory 
(geiser-chicken-load-paths))))))))
+
+  (define (geiser-compile-file file . rest)
+    #f)
+
+    ;; TODO: Support compiling regions
+
+  (define (geiser-compile form module . rest)
+    (error "Chicken does not support compiling regions"))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Modules
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  ;; Should return:
+  ;; '(("modules" . sub-modules) ("procs" . procedures) ("syntax" . macros) 
("vars" . variables))
+  (define (geiser-module-exports module-name . rest)
+    '())
+
+  ;; Returns the path for the file in which an egg or module was defined
+
+  (define (geiser-module-path module-name . rest)
+    #f)
+
+  ;; Returns:
+  ;; `(("file" . ,(module-path name)) ("line"))
+
+  (define (geiser-module-location name . rest)
+    #f)
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Misc
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (define (geiser-macroexpand form . rest)
+    (with-output-to-string
+      (lambda ()
+        (write (expand form)))))
+
+;; End module
+  )