Added support for swank/slime prompt.

Pascal J. Bourguignon [2021-03-01 06:21]
Added support for swank/slime prompt.
Filename
small-cl-pgms/irclog-prompter/com.informatimago.small-cl-pgms.irclog.asd
small-cl-pgms/irclog-prompter/main.lisp
small-cl-pgms/irclog-prompter/prompter-test.lisp
small-cl-pgms/irclog-prompter/prompter.lisp
diff --git a/small-cl-pgms/irclog-prompter/com.informatimago.small-cl-pgms.irclog.asd b/small-cl-pgms/irclog-prompter/com.informatimago.small-cl-pgms.irclog.asd
index 6fcad17..961f44b 100644
--- a/small-cl-pgms/irclog-prompter/com.informatimago.small-cl-pgms.irclog.asd
+++ b/small-cl-pgms/irclog-prompter/com.informatimago.small-cl-pgms.irclog.asd
@@ -42,8 +42,9 @@
                ;; "cl-irc" "cl-json"
                "drakma" "split-sequence" "cl-ppcre")
   :components ((:file "irclog")
-               (:file "prompter")
+               (:file "swank-slime")
+               (:file "prompter"      :depends-on ("swank-slime"))
                (:file "prompter-test" :depends-on ("prompter"))
-               (:file "main" :depends-on ("prompter" "irclog"))))
+               (:file "main" :depends-on ("prompter" "irclog" "swank-slime"))))

 ;;;; THE END ;;;;
diff --git a/small-cl-pgms/irclog-prompter/main.lisp b/small-cl-pgms/irclog-prompter/main.lisp
index 9632390..bcb10ea 100644
--- a/small-cl-pgms/irclog-prompter/main.lisp
+++ b/small-cl-pgms/irclog-prompter/main.lisp
@@ -4,8 +4,7 @@
         "COM.INFORMATIMAGO.SMALL-CL-PGMS.PROMPTER")
   (:documentation "This package fetches new lines from irclogs,
 and displays them before the next prompt.")
-  (:export "MAIN"))
-
+  (:export "START"))
 (in-package "COM.INFORMATIMAGO.SMALL-CL-PGMS.IRCLOG.MAIN")

 (defun display-new-irc-messages ()
@@ -17,9 +16,9 @@ and displays them before the next prompt.")
                       :do (format t "#~A: ~A~%" channel message)))
       (force-output))))

-(defun main ()
+(defun start ()
   (install-prompt-functions)
   (add-prompt-function 'display-new-irc-messages)
   (values))

-(main)
+;;;; THE END ;;;;
diff --git a/small-cl-pgms/irclog-prompter/prompter-test.lisp b/small-cl-pgms/irclog-prompter/prompter-test.lisp
index 2db20e1..83f2c2f 100644
--- a/small-cl-pgms/irclog-prompter/prompter-test.lisp
+++ b/small-cl-pgms/irclog-prompter/prompter-test.lisp
@@ -3,14 +3,33 @@
         "COM.INFORMATIMAGO.SMALL-CL-PGMS.PROMPTER"))
 (in-package "COM.INFORMATIMAGO.SMALL-CL-PGMS.PROMPTER.TEST")

-(assert (eq (ADD-PROMPT-FUNCTION 'com.informatimago.common-lisp.interactive.interactive:date)
-            'com.informatimago.common-lisp.interactive.interactive:date))
-(assert (eq (REMOVE-PROMPT-FUNCTION 'com.informatimago.common-lisp.interactive.interactive:date)
-            'com.informatimago.common-lisp.interactive.interactive:date))
-(assert (null (LIST-PROMPT-FUNCTIONS)))
-(assert (eq (ADD-PROMPT-FUNCTION 'com.informatimago.common-lisp.interactive.interactive:date)
-            'com.informatimago.common-lisp.interactive.interactive:date))
-(assert (equal (LIST-PROMPT-FUNCTIONS)
-               '(com.informatimago.common-lisp.interactive.interactive:date)))
+(defun date (&optional (date (get-universal-time)))
+  "Prints the date."
+  (format t "~&~{~5*~4,'0D-~2:*~2,'0D-~2:*~2,'0D ~2:*~2,'0D:~2:*~2,'0D:~2:*~2,'0D~8*~}~%"
+          (multiple-value-list (decode-universal-time date)))
+  date)
+
+
+(assert (eq (ADD-PROMPT-FUNCTION 'date)
+            'date))
+(assert (eq (REMOVE-PROMPT-FUNCTION 'date)
+            'date))
+
+(let ((old  (LIST-PROMPT-FUNCTIONS)))
+  (dolist (fun old)
+    (REMOVE-PROMPT-FUNCTION fun))
+
+  (unwind-protect
+       (progn
+         (assert (null (LIST-PROMPT-FUNCTIONS)))
+         (assert (eq (ADD-PROMPT-FUNCTION 'date)
+                     'date))
+         (assert (equal (LIST-PROMPT-FUNCTIONS)
+                        '(date))))
+
+    (dolist (fun  (LIST-PROMPT-FUNCTIONS))
+      (REMOVE-PROMPT-FUNCTION fun))
+    (dolist (fun old)
+      (ADD-PROMPT-FUNCTION fun))))

 ;;;; THE END ;;;;
diff --git a/small-cl-pgms/irclog-prompter/prompter.lisp b/small-cl-pgms/irclog-prompter/prompter.lisp
index fe21b61..00b28d9 100644
--- a/small-cl-pgms/irclog-prompter/prompter.lisp
+++ b/small-cl-pgms/irclog-prompter/prompter.lisp
@@ -1,5 +1,6 @@
 (defpackage "COM.INFORMATIMAGO.SMALL-CL-PGMS.PROMPTER"
   (:use "COMMON-LISP")
+  (:use "COM.INFORMATIMAGO.SMALL-CL-PGMS.SLIME")
   (:documentation "This package installs functions to be called before the REPL prompt is displayed.")
   (:export "ADD-PROMPT-FUNCTION"
            "REMOVE-PROMPT-FUNCTION"
@@ -58,7 +59,12 @@ STREAM is flushed."
     ;; and the prompt is displayed by emacs.
     ;; Therefore this feature must be implemented in emacs.
     #+swank (progn
-              )
+              (eval-in-emacs '(defadvice slime-repl-insert-prompt
+                               (before slime-repl-insert-prompt/run-prompt-functions last () activate)
+                               (slime-eval (car (read-from-string "(com.informatimago.small-cl-pgms.prompter::run-prompt-functions cl:*standard-output*)"))))))
+
+    ;; We still hook in the prompt for *inferior-lisp*,
+    ;; and for the normal case (terminal):

     ;; For ccl, we cannot use the *read-loop-function* since once we're
     ;; inside the loop, this hook is not used anymore (it's used when
@@ -86,7 +92,15 @@ STREAM is flushed."
                            (funcall old-prompt-fun stream)
                            (finish-output stream))))))

-    #-(or ccl sbcl) (error "Not implemented yet for ~A" (lisp-implementation-type))
+    #-(or ccl sbcl)
+    (error "~S is not implemented yet for ~A"
+           'install-prompt-functions (lisp-implementation-type))
     (setf *prompt-functions-installed* t)))

+#-(and)
+(progn
+  (setf *prompt-functions-installed* nil
+        #+sbcl sb-int:*repl-prompt-fun* #+sbcl (function com.informatimago.pjb::prompt))
+  (install-prompt-functions))
+
 ;;;; THE END ;;;;
ViewGit