Permalink
Switch branches/tags
Nothing to show
Find file
Fetching contributors…
Cannot retrieve contributors at this time
664 lines (574 sloc) 22.1 KB
;;;
;;; Copyright (c) 2010-2011 Nick Gasson
;;;
;;; Permission is hereby granted, free of charge, to any person obtaining a
;;; copy of this software and associated documentation files (the "Software"),
;;; to deal in the Software without restriction, including without limitation
;;; the rights to use, copy, modify, merge, publish, distribute, sublicense,
;;; and/or sell copies of the Software, and to permit persons to whom the
;;; Software is furnished to do so, subject to the following conditions:
;;;
;;; The above copyright notice and this permission notice shall be included in
;;; all copies or substantial portions of the Software.
;;;
;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
;;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
;;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
;;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
;;; DEALINGS IN THE SOFTWARE.
;;;
(import chicken scheme)
(require 'tcp)
(require 'posix)
(require-extension data-structures
symbol-utils
apropos
chicken-doc
extras
fmt
srfi-14
trace)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;
;;; SWANK server
;;;
;;; This section provides the plumbing to allow SLIME to tunnel requests into
;;; the swank:* functions in the next section which do the useful work.
;;;
;;; To start a server do:
;;; (swank-server-start)
;;;
;;; Then connect to it from Emacs using:
;;; M-x slime-connect
;;; And accept the default options.
;;;
;; Safe printing routine that always uses the server's standard output.
(define debug-print
(let ((normal-port (current-output-port)))
(lambda args
(with-output-to-port normal-port
(lambda ()
(apply print args)))
(flush-output normal-port))))
;; Send list `msg' as a reply back to SLIME.
(define (swank-write-packet msg out)
(let* ((string (with-output-to-string
(lambda ()
(write msg))))
(pad-hex (lambda (n)
(pad-char #\0 (pad/left 6 (num n 16)))))
(packet (fmt #f (pad-hex (string-length string)) string)))
;; This may be called by code that has set print-length-limit so we
;; have to use this kludge to avoid truncating the packet.
(##sys#with-print-length-limit #f (lambda ()
(debug-print (fmt #f "WRITE " (wrt packet)))
(display packet out)))
(flush-output out)))
;; Replace Common Lisp-isms such as :foo, nil, and t with (quote foo),
;; (quote ()), and #t respectively.
(define (swank-cleanup sexp)
(define (cleanup-symbol sym)
(let ((sym-str (symbol->string sym)))
(cond
((eq? (string-ref sym-str 0) #\:)
`(quote ,(string->symbol (substring sym-str 1))))
((eq? sym 'nil)
'(quote ()))
((eq? sym 't)
#t)
(else sym))))
(cond
((list? sexp)
(map swank-cleanup sexp))
((symbol? sexp)
(cleanup-symbol sexp))
(else sexp)))
;; Tail-recursive loop to read commands from SWANK socket and dispatch them.
;; Several calls to this may be active at once e.g. when using the debugger.
(define (swank-event-loop in out)
(let* ((length (read in))
(request (read in)))
(cond
((or (eof-object? length) (eof-object? request))
(void))
(else
(debug-print (fmt #f "READ " (wrt length) (wrt request)))
(case (car request)
((:emacs-rex)
(begin
(apply swank-emacs-rex in out (swank-cleanup (cdr request)))
(swank-event-loop in out)))
((:emacs-return-string)
(cadddr request)))))))
;; Store the callchain away for later inspection
(define *recent-call-chain* #f)
;; Format the call chain for output by SLIME.
(define (swank-call-chain chain)
(define (frame-string f)
(fmt #f (pad 9 (dsp (vector-ref f 0)))
(pad 11 (dsp (cond
((##sys#structure? (vector-ref f 2) 'frameinfo) "[ more... ]")
(else ""))))
" "
(dsp (or (vector-ref f 1) ""))))
(define (loop n frames)
(cond
((null? frames) '())
(else (cons (list n (frame-string (car frames)))
(loop (add1 n) (cdr frames))))))
(loop 0 (reverse chain)))
;; Called when an exception is thrown while evaluating a swank:* function.
(define (swank-exception in out id exn chain)
(let ((get-key (lambda (key)
((condition-property-accessor 'exn key '()) exn))))
(debug-print (fmt #f "ERROR msg: " (get-key 'message)
" args: " (get-key 'arguments)
" loc " (get-key 'location)))
(let ((first-line (fmt #f "Error: "
(cond
((get-key 'location) => (lambda (l)
(fmt #f "(" l ") ")))
(else ""))
(get-key 'message)
": " (fmt-join wrt (get-key 'arguments) " "))))
(swank-write-packet
`(:debug 0 0 ; Thread, level (dummy values)
(,first-line "[ inspect ]" nil) ; Condition
(("ABORT" "Return to SLIME's top level")) ; Restarts
,(swank-call-chain chain) ; Frames
(,id)) ; Emacs continuations
out))
(dynamic-wind
(lambda ()
(swank-write-packet '(:debug-activate 0 0 nil) out))
(lambda ()
(swank-event-loop in out))
(lambda ()
(swank-write-packet '(:debug-return 0 0 nil) out)))))
;; Create an output port that sends data back to SLIME to be printed on
;; the REPL.
(define (swank-output-port out)
(make-output-port
(lambda (str)
(swank-write-packet `(:write-string ,(fmt #f str))
out))
void
void))
;; Create an input port that reads data by calling back into Emacs.
(define (swank-input-port in out)
(let ((buffer #f))
(define (read-callback)
(if buffer
(let ((char (read-char buffer)))
(if (eof-object? char)
(begin
(set! buffer #f)
(read-callback))
char))
(begin
(swank-write-packet '(:read-string 0 1) out)
(let ((result (swank-event-loop in out)))
(if (string? result)
(begin
(set! buffer
(with-input-from-string result current-input-port))
(read-callback))
#!eof)))))
(define (ready-callback) buffer)
(make-input-port read-callback ready-callback void)))
;; Evaluate an S-expression and returns a pair (condition . trace) if an
;; exception is raised or (#t . value) on success.
(define (swank-eval-or-condition sexp)
(call-with-current-continuation
(lambda (skip)
(with-exception-handler
(lambda (exn)
(let ((chain (or
((condition-property-accessor
'exn
'call-chain
#f) exn)
(get-call-chain))))
(set! *recent-call-chain* (reverse chain))
(skip (cons exn chain))))
(lambda ()
(cons #t (eval sexp)))))))
;; The only SWANK command we handle at the moment. Argument is an expression
;; to be evaluated, which should be a call to a swank:* function. Any output
;; produced by the expression will be returned to SLIME as a string. Any
;; error generated by the expression will be caught in the exception handler
;; above.
(define (swank-emacs-rex in out sexp package thread id)
(let ((result `(:return (:abort nil) ,id)))
(dynamic-wind
void
(lambda ()
(let ((thing (with-output-to-port (swank-output-port out)
(lambda ()
(with-input-from-port (swank-input-port in out)
(lambda ()
(swank-eval-or-condition sexp)))))))
(cond
((not (condition? (car thing)))
(set! result `(:return ,(cdr thing) ,id)))
(((condition-predicate 'exn) (car thing))
(swank-exception in out id (car thing) (cdr thing)))
(((condition-predicate 'user-interrupt) (car thing))
(set! result `(:return (:abort user-interrupt) ,id))))))
;; Output is always written when unwinding the stack to ensure we
;; reply to every message e.g. when escaping via continuation to
;; the top level after exiting the debugger.
(lambda ()
(swank-write-packet result out)))))
;; The top level continuation. By invoking this we can jump out of the
;; debugger and get back to the REPL.
(define *swank-top-level* #f)
;; Start up a TCP server, wait for a connection, then jump into the main
;; event loop. If `file' is specified it is used as a filename to write
;; the server port number into. This is polled by SLIME to see if the
;; SWANK server has started. Use `swank-server-start' rather than calling
;; this directly.
(define (swank-make-server port file)
(define (write-port-file port file)
(call-with-output-file file
(lambda (handle)
(write port handle))))
(tcp-read-timeout #f)
(let ((listener (tcp-listen port)))
(if file
(write-port-file port file))
(dynamic-wind
(lambda () #f)
(lambda ()
(call-with-values
(lambda () (tcp-accept listener))
(lambda (in out)
(call/cc (lambda (hop)
(set! *swank-top-level* hop)))
;; Whenever we escape from the debugger we'll end up here
(let ((orig-handler (current-exception-handler)))
(with-exception-handler
(lambda (exn)
(cond
(((condition-predicate 'user-interrupt) exn)
(*swank-top-level* (void)))
(else
(orig-handler exn))))
(lambda ()
(swank-event-loop in out)))))))
(lambda ()
(tcp-close listener)))))
;; Wrapper for `swank-make-server' with optional `port' and `file' arguments.
(define swank-server-start
(case-lambda
(() (swank-make-server 4005 #f))
((port) (swank-make-server port #f))
((port file) (swank-make-server port file))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; SWANK commands
;;;
;;; The functions in this section implement the SWANK API proper.
;;;
;; Called at startup to determine various information about the inferior
;; Lisp process.
(define (swank:connection-info)
`(:ok (:pid ,(current-process-id)
:package (:name CSI :prompt CSI)
:encoding (:coding-systems (,swank:coding-system))
:lisp-implementation
(:type "Chicken Scheme" :version ,(chicken-version)))))
;; For us this call is fairly pointless, but it names the REPL.
(define (swank:create-repl . _)
'(:ok ("CSI" "CSI")))
(define swank-repl:create-repl swank:create-repl)
;; Parse `str' into a list of forms.
(define (string->forms str)
(define (get-forms)
(let ((form (read)))
(cond
((eof-object? form) '())
(else (cons form (get-forms))))))
(with-input-from-string str get-forms))
;; Evaluate `str' as if enclosed in (begin ...) and return the results.
(define (swank:listener-eval str)
(call-with-values
(lambda ()
(let ((forms (string->forms str)))
(if (not (null? forms))
(eval `(begin ,@forms)))))
(lambda results
`(:ok (:values ,@(map (lambda (r)
(fmt #f (wrt r)))
results))))))
(define swank-repl:listener-eval swank:listener-eval)
;; "Compile" a string. For us this just means eval and discard the
;; results, the behaviour of which might be different to what SLIME
;; or the user expected.
(define (swank:compile-string-for-emacs str buffer position filename _)
(let ((forms (string->forms str)))
(for-each (lambda (form)
(eval form))
forms)
`(:ok (:compilation-result nil t 0.0 nil nil)))) ; TODO: eval time
;; Evaluate an expression and return a result for the minibuffer.
(define (swank:interactive-eval str)
(let* ((forms (string->forms str))
(result (if (not (null? forms))
(fmt #f "=> " (eval `(begin ,@forms)))
"; No value")))
`(:ok ,result)))
(define swank:interactive-eval-region swank:interactive-eval)
;; Evaluate an expression and pretty-print the result.
(define (swank:pprint-eval str)
`(:ok ,(fmt #f (pretty (eval `(begin ,@(string->forms str)))))))
;; Given a function name return a list of its arguments. This uses
;; the symbol-utils extension.
(define (swank:operator-arglist func _)
`(:ok ,(let ((sym (string->symbol func)))
(cond
((unbound? sym) 'nil)
((procedure? (symbol-value sym))
(fmt #f (procedure-information (symbol-value sym))))
(else 'nil)))))
;; Immediately return from all nested debugging sessions back to
;; the top level.
(define (swank:throw-to-toplevel)
(*swank-top-level* (void)))
;; Invoke the given debug restart. We only support one restart at
;; the moment which jumps back to the top level.
(define (swank:invoke-nth-restart-for-emacs _ _)
(*swank-top-level* (void)))
;; Return the local variables for frame n
;(:ok (((:name "SB-DEBUG::ARG-0"
; :id 0 :value "(ERROR \"foo\")")
; (:name "SB-DEBUG::ARG-1" :id 0
; :value "#<NULL-LEXENV>")) nil))
(define (frame-info callframe)
(let* ((form (##sys#slot callframe 1))
(data (##sys#slot callframe 2))
(frameinfo (##sys#structure? data 'frameinfo))
(counter (if frameinfo (##sys#slot frameinfo 1) data)))
(if frameinfo
(let ((ev-list (fold append '()
(map
(lambda (e v)
(do ((i 0 (add1 i))
(be e (cdr be))
(res '()))
((null? be) res)
(set! res (cons (list ':name (symbol->string (car be))
':id i
':value (->string (##sys#slot v i)))
res))))
(##sys#slot data 2)
(##sys#slot data 3)))))
(if (null? ev-list) 'nil ev-list))
'nil)))
(define (get-local frame index)
(and-let* ((vars (frame-info frame))
(frame (and (> (length vars) index)
(list-ref vars index))))
(fprintf (current-error-port) "~a -> ~a~%~!" vars frame)
frame))
(define (variable-from-callchain frame-idx var-idx)
(and-let* ((chain *recent-call-chain*)
(frame (and (> (length chain) frame-idx)
(list-ref chain frame-idx))))
(get-local frame var-idx)))
(define (swank:frame-locals-and-catch-tags n . _)
(let ((cc *recent-call-chain*))
(if (and cc
(>= n 0)
(< n (length cc)))
`(:ok (,(frame-info (list-ref cc n)) nil))
'(:ok (nil nil)))))
;; Return the backtrace frames between `start' and `end'.
;; TODO: currently does nothing as we only seem to get eight stack
;; frames from get-call-chain.
(define (swank:backtrace start end)
'(:ok nil))
;; Load the specified file.
(define (swank:load-file file)
(load file)
`(:ok t))
;; A more advanced version of swank:operator-arglist which highlights
;; the the current cursor position in the argument list.
(define (swank:autodoc forms . args)
(define (find-cursor thing)
(cond
((and (list? thing)
(memq 'swank::%cursor-marker% thing))
thing)
((list? thing)
(let loop ((elems thing))
(if (null? elems)
#f
(or (find-cursor (car elems))
(loop (cdr elems))))))
(else #f)))
(define (highlight-arg info args)
(cond
((null? info) '())
((null? args) info)
((not (pair? info)) ; Variable length argument list
(list '===> info '<===))
((eq? (car args) 'swank::%cursor-marker%)
(append (list '===> (car info) '<===)
(cdr info)))
((and (string? (car args)) (string=? (car args) ""))
(highlight-arg info (cdr args)))
(else (cons (car info)
(highlight-arg (cdr info) (cdr args))))))
(define (symbol-procedure? sym)
(handle-exceptions exn #f (procedure? (eval sym))))
(define (info sym)
(cond
((unbound? sym) #f)
((symbol-procedure? sym)
(let ((pi (procedure-information (symbol-value sym))))
(if (pair? pi)
pi
`(,pi . args))))
(else #f)))
;; Choose a doc-node from all matches, this is only a heuristic solution.
;; The heuristic is to find the doc node that has the same name as the symbol,
;; and the module name is listed in ##sys#module-table. If there are multiple
;; such nodes, choose the first one.
;;
(define (guess-doc-node doc-nodes)
(case (length doc-nodes)
((0) #f)
;; ((1) (car doc-nodes))
(else (any (lambda (n) (and (assoc (car (chicken-doc#node-path n))
##sys#module-table)
n))
doc-nodes))))
(define (signature-from-doc sym)
(cond ((eq? sym 'define) ))
(if (or (##sys#macro? sym) (symbol-procedure? sym))
(let* ((doc-nodes (match-nodes sym))
(guessed-doc-node (guess-doc-node doc-nodes)))
(cond
((null? doc-nodes) #f)
(guessed-doc-node
(car (string->forms
(string-delete (char-set #\[ #\])
(chicken-doc#node-signature guessed-doc-node)))))
(else #f)))
#f))
(let ((where (find-cursor forms)))
(if (and where (string? (car where)))
(let* ((sym (string->symbol (car where)))
(i (or (signature-from-doc sym) (info sym))))
(if i
`(:ok (,(fmt #f (highlight-arg i where)) t))
`(:ok (:not-available t))))
'(:ok (:not-available t)))))
;; Return a list of all symbols that start with `prefix'.
(define (swank:simple-completions prefix _)
(let ((comps (filter (lambda (str)
(string-prefix? prefix str))
(map (lambda (info)
(symbol->string (car info)))
(apropos-information-list prefix)))))
`(:ok (,comps ,(if (= (length comps) 1)
(car comps)
prefix)))))
(define (swank:describe-symbol sym)
`(:ok ,(with-output-to-string
(lambda ()
(doc-dwim sym)))))
(define swank:documentation-symbol swank:describe-symbol)
(define (swank:describe-definition-for-emacs sym type)
(swank:describe-symbol sym))
(define (swank:apropos-list-for-emacs str . _)
(define (slime-node-type node)
(case (node-type node)
((procedure) ':function)
((read syntax) ':macro)
((setter) ':setf)
((class) ':class)
((method) ':generic-function)
;((egg) ':egg) ; Not visible
(else ':variable)))
`(:ok ,(map (lambda (node)
(list ':designator (fmt #f (node-id node))
(slime-node-type node) (node-signature node)))
(match-nodes (irregex str)))))
(define (swank:inspect-frame-var frame index)
;; an answer seems to be
;; (:ok (:id number :title "variable-name"
;; :content (( "type" (:value variable-value id))) begin end length))
;; whereas begin and end are used to display a chunk out of a longer list of things
;; the id in variable value can be used to further inquire a value
;; The return of variable form callchain is (:name name :id id :value)
;; TODO: Use csi's describe function for the content part
(and-let* ((var (variable-from-callchain frame index))
(name (second var))
(id (fourth var))
(value (sixth var))
(value-len (or
(and (list? value) (length value))
1)))
`(:ok (:id 0
:title ,(->string name)
:content (("unknown type? " (:value ,(->string value) 1)) 0 0 ,value-len)))))
(define (swank:quit-inspector)
'(:ok nil))
(define swank:coding-system "utf-8-unix")
(define (swank:default-directory)
`(:ok ,(current-directory)))
(define (swank:set-default-directory sym)
`(:ok ,(current-directory sym)))
;; Unimplemented.
(define (swank:buffer-first-change . _) '(:ok nil))
(define (swank:filename-to-modulename . _) '(:ok nil))
(define (swank:find-definitions-for-emacs . _) '(:ok nil))
(define (swank:swank-require . _) '(:ok nil))
(define (swank:init-presentations . _) '(:ok nil))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Trace
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; (:ok "DEFUN is now traced for trace dialog")
; (:ok "DEFUN is now untraced for trace dialog")
; (:debug 1 1 ("invalid function name: 12312" " [Condition of type SIMPLE-TYPE-ERROR]" nil)
(define (swank-trace-dialog:dialog-toggle-trace symbol) '(:ok nil))
(define (swank-trace-dialog:dialog-untrace symbol) '(:ok nil))
; (:ok (common-lisp:defun))
(define (swank-trace-dialog:report-specs) '(:ok nil))
; (:ok 0) ; number of recorded traces
(define (swank-trace-dialog:report-total) '(:ok 0))
; (:ok
; (((0 nil common-lisp-user::foo nil
; (...))
; (1 nil common-lisp-user::foo nil
; (...)))
; 0 slime-trace-dialog-fetch-key-83333))
(define (swank-trace-dialog:report-partial-tree fetch-key) '(:ok nil))
; (:ok
; (:title "#<BIT {2}>" :id 0 :content
; (("Value: 1 = #x00000001 = #o1 = #b1 = 1.e+0" "\n" "Code-char" ": "
; (:value "#\\Soh" 1)
; "\n" "Integer-length" ": "
; (:value "@0=1" 2)
; "\n" "Universal-time" ": "
; (:value "\"1899-12-31T16:00:01-08:00\"" 3)
; "\n")
; 14 0 500)))
; swank-trace-dialog:inspect-trace-part 0 0 :retval
(define (swank-trace-dialog:inspect-trace-part id return-value-index detail) '(:ok nil))
; (:ok
; (5 nil common-lisp-user::foo nil
; ((0 "1"))
; nil "#<5: FOO>")
(define (swank-trace-dialog:report-trace-detail id)
'(:ok nil))
; (:ok nil)
(define (swank-trace-dialog:clear-trace-tree) '(:ok nil))
; (:ok nil)
(define (swank-trace-dialog:dialog-untrace-all) '(:ok nil))
(define (swank:init-presentations . _) '(:ok nil))
(define (swank-repl:create-repl . _)
'(:ok ("CSI" "CSI")))