Merge pull request #842 from lem-project/add-repl-shortcut-ls

Add repl shortcut `ls` and `pwd`

modes/lisp-mode/repl.lisp

@@ -77,17 +77,27 @@
                                           "(cl:pprint (micros:get-printed-object-by-id ~A))"
                                           id)))))))
 
+(defun context-menu-copy-down-pathname-to-repl ()
+  (lem/context-menu:make-item
+   :label "Copy down pathname to REPL"
+   :callback (lambda (&rest args)
+               (declare (ignore args))
+               (copy-down-to-repl 'pathname
+                                  (lem/directory-mode::get-pathname (current-point))))))
+
 (defun repl-compute-context-menu-items ()
-  (remove
-   nil
-   (list (context-menu-describe-symbol)
-         (context-menu-find-definition)
-         (context-menu-find-references)
-         (context-menu-hyperspec)
-         (context-menu-inspect-printed-object)
-         (context-menu-copy-down-printed-object)
-         (context-menu-describe-object)
-         (context-menu-pretty-print))))
+  (if (lem/directory-mode::get-pathname (current-point))
+      (list (context-menu-copy-down-pathname-to-repl))
+      (remove
+       nil
+       (list (context-menu-describe-symbol)
+             (context-menu-find-definition)
+             (context-menu-find-references)
+             (context-menu-hyperspec)
+             (context-menu-inspect-printed-object)
+             (context-menu-copy-down-printed-object)
+             (context-menu-describe-object)
+             (context-menu-pretty-print)))))
 
 (defun read-string-thread-stack ()
   (buffer-value (repl-buffer) 'read-string-thread-stack))
@@ -123,53 +133,6 @@
      argument)
   (lisp-eval-async '(micros:clear-printed-objects)))
 
-(defvar *lisp-repl-shortcuts* '())
-
-(defmacro with-repl-prompt (() &body body)
-  `(let ((lem/prompt-window:*prompt-completion-window-shape* nil))
-     ,@body))
-
-(defun repl-prompt-for-string (prompt &rest args)
-  (with-repl-prompt ()
-    (apply #'prompt-for-string
-           prompt
-           :gravity :cursor
-           :use-border nil
-           args)))
-
-(defun prompt-for-shortcuts ()
-  (let* ((*lisp-repl-shortcuts* *lisp-repl-shortcuts*)
-         (names (mapcar #'car *lisp-repl-shortcuts*)))
-    (cdr (assoc (repl-prompt-for-string
-                 "Command: "
-                 :completion-function (lambda (x) (completion-strings x names))
-                 :test-function (lambda (name) (member name names :test #'string=))
-                 :history-symbol 'mh-lisp-repl-shortcuts)
-                *lisp-repl-shortcuts* :test #'equal))))
-
-(define-command lisp-repl-shortcut (n) ("p")
-  (with-point ((point (current-point)))
-    (if (point>= (lem/listener-mode:input-start-point (current-buffer)) point)
-        (let ((fun (prompt-for-shortcuts)))
-          (when fun
-            (funcall fun)))
-        (let ((c (insertion-key-p (last-read-key-sequence))))
-          (insert-character point c n)))))
-
-(defmacro define-repl-shortcut (name lambda-list &body body)
-  (if (and (not (null lambda-list))
-           (symbolp lambda-list))
-      `(progn
-         (setf *lisp-repl-shortcuts*
-               (remove ,(string-downcase name) *lisp-repl-shortcuts* :key 'first :test 'equal))
-         (push (cons ,(string-downcase name) ',lambda-list) *lisp-repl-shortcuts*)
-         ',name)
-      `(progn
-         (setf *lisp-repl-shortcuts*
-               (remove ,(string-downcase name) *lisp-repl-shortcuts* :key 'first :test 'equal))
-         (push (cons ,(string-downcase name) ',name) *lisp-repl-shortcuts*)
-         (defun ,name ,lambda-list ,@body))))
-
 (defun repl-buffer ()
   (get-buffer "*lisp-repl*"))
 
@@ -469,6 +432,66 @@
         (string
          (insert-string point token :attribute current-attribute))))))
 
+(define-command backward-prompt () ()
+  (when (equal (current-buffer) (repl-buffer))
+    (move-to-previous-virtual-line (current-point))
+    (lem:previous-single-property-change (lem:current-point) :field)))
+
+(define-command forward-prompt () ()
+  (when (equal (current-buffer) (repl-buffer))
+    (move-to-next-virtual-line (current-point))
+    (lem:next-single-property-change (lem:current-point) :field)
+    (lem:next-single-property-change (lem:current-point) :field)))
+
+
+;;; repl-shortcut
+(defvar *lisp-repl-shortcuts* '())
+
+(defmacro with-repl-prompt (() &body body)
+  `(let ((lem/prompt-window:*prompt-completion-window-shape* nil))
+     ,@body))
+
+(defun repl-prompt-for-string (prompt &rest args)
+  (with-repl-prompt ()
+    (apply #'prompt-for-string
+           prompt
+           :gravity :cursor
+           :use-border nil
+           args)))
+
+(defun prompt-for-shortcuts ()
+  (let* ((*lisp-repl-shortcuts* *lisp-repl-shortcuts*)
+         (names (mapcar #'car *lisp-repl-shortcuts*)))
+    (cdr (assoc (repl-prompt-for-string
+                 "Command: "
+                 :completion-function (lambda (x) (completion-strings x names))
+                 :test-function (lambda (name) (member name names :test #'string=))
+                 :history-symbol 'mh-lisp-repl-shortcuts)
+                *lisp-repl-shortcuts* :test #'equal))))
+
+(define-command lisp-repl-shortcut (n) ("p")
+  (with-point ((point (current-point)))
+    (if (point>= (lem/listener-mode:input-start-point (current-buffer)) point)
+        (let ((fun (prompt-for-shortcuts)))
+          (when fun
+            (funcall fun)))
+        (let ((c (insertion-key-p (last-read-key-sequence))))
+          (insert-character point c n)))))
+
+(defmacro define-repl-shortcut (name lambda-list &body body)
+  (if (and (not (null lambda-list))
+           (symbolp lambda-list))
+      `(progn
+         (setf *lisp-repl-shortcuts*
+               (remove ,(string-downcase name) *lisp-repl-shortcuts* :key 'first :test 'equal))
+         (push (cons ,(string-downcase name) ',lambda-list) *lisp-repl-shortcuts*)
+         ',name)
+      `(progn
+         (setf *lisp-repl-shortcuts*
+               (remove ,(string-downcase name) *lisp-repl-shortcuts* :key 'first :test 'equal))
+         (push (cons ,(string-downcase name) ',name) *lisp-repl-shortcuts*)
+         (defun ,name ,lambda-list ,@body))))
+
 (define-repl-shortcut sayonara ()
   (if (self-connection-p *connection*)
       (message "Can't say sayonara because it's self connection.")
@@ -495,7 +518,8 @@
                                    :directory (buffer-directory)
                                    :gravity :cursor
                                    :use-border nil))))
-    (lisp-set-directory :directory directory)))
+    (setf (buffer-directory (current-buffer))
+          (micros/backend:filename-to-pathname directory))))
 
 (defun prompt-for-system (prompt)
   (let ((systems (lisp-eval '(micros:list-systems))))
@@ -509,13 +533,13 @@
   (let ((system (prompt-for-system "Quickload System: ")))
     (listener-eval (prin1-to-string `(ql:quickload ,system)))))
 
-(define-command backward-prompt () ()
-  (when (equal (current-buffer) (repl-buffer))
-    (move-to-previous-virtual-line (current-point))
-    (lem:previous-single-property-change (lem:current-point) :field)))
+(define-repl-shortcut ls ()
+  (insert-character (current-point) #\newline)
+  (lem/directory-mode::insert-directories-and-files (current-point)
+                                                    (buffer-directory (current-buffer)))
+  (lem/listener-mode:refresh-prompt (current-buffer)))
 
-(define-command forward-prompt () ()
-  (when (equal (current-buffer) (repl-buffer))
-    (move-to-next-virtual-line (current-point))
-    (lem:next-single-property-change (lem:current-point) :field)
-    (lem:next-single-property-change (lem:current-point) :field)))
+(define-repl-shortcut pwd ()
+  (insert-string (current-point)
+                 (format nil "~%~A~%" (buffer-directory (current-buffer))))
+  (lem/listener-mode:refresh-prompt (current-buffer)))

src/ext/directory-mode.lisp

@@ -15,8 +15,17 @@
 
   A keyword, one of :pathname (sort by file name), :mtime (last modification time) and :size.")
 
+(define-attribute current-directory-attribute
+  (t :bold t :foreground :base0B))
+
+(define-attribute file-size-attribute
+  (t :bold t))
+
+(define-attribute file-date-attribute
+  (t :bold t))
+
 (define-attribute file-attribute
-  (t))
+  (t :bold t))
 
 (define-attribute directory-attribute
   (t :foreground :base0D :bold t))
@@ -62,18 +71,24 @@
     (when (string/= error-string "")
       (editor-error "~A" error-string))))
 
-(defun update-line (point &optional move-cursor-to-file-position)
+(defun remove-line-overlay-when-buffer-change (point arg)
+  (declare (ignore arg))
+  (alexandria:when-let (ov (buffer-value (point-buffer point) 'line-overlay))
+    (setf (buffer-value (point-buffer point) 'line-overlay) nil)
+    (delete-overlay ov)))
+
+(defun update-line (point)
   (with-point ((start point)
                (end point))
-    (back-to-indentation (line-start start))
+    (back-to-indentation start)
     (line-end end)
-    (when move-cursor-to-file-position
-      (move-point point start))
     (let ((ov (buffer-value point 'line-overlay)))
       (cond (ov
              (move-point (overlay-start ov) start)
              (move-point (overlay-end ov) end))
             (t
+             (add-hook (variable-value 'before-change-functions :buffer (point-buffer point))
+                       'remove-line-overlay-when-buffer-change)
              (setf ov (make-overlay start end 'region))
              (setf (buffer-value point 'line-overlay) ov))))))
 
@@ -96,15 +111,16 @@
 
 (defun set-mark (p mark)
   (with-buffer-read-only (point-buffer p) nil
-    (with-point ((p p))
-      (let ((pathname (get-line-property p 'pathname)))
-        (when (and pathname (not (uiop:pathname-equal
-                                  pathname
-                                  (uiop:pathname-parent-directory-pathname
-                                   (buffer-directory (point-buffer p))))))
-          (character-offset (line-start p) 1)
-          (delete-character p 1)
-          (insert-character p (if mark #\* #\space)))))))
+    (let ((*inhibit-read-only* t))
+      (with-point ((p p))
+        (let ((pathname (get-line-property p 'pathname)))
+          (when (and pathname (not (uiop:pathname-equal
+                                    pathname
+                                    (uiop:pathname-parent-directory-pathname
+                                     (buffer-directory (point-buffer p))))))
+            (character-offset (line-start p) 1)
+            (delete-character p 1)
+            (insert-character p (if mark #\* #\space))))))))
 
 (defun iter-marks (p function)
   (with-point ((p p))
@@ -171,9 +187,11 @@
   (with-point ((start point))
     (let ((name (or content (namestring (enough-namestring pathname directory)))))
       (insert-string point "  " 'pathname pathname 'name name)
-      (insert-string point (format nil " ~5@A "
-                                   (let ((size (file-size pathname)))
-                                     (if size (human-readable-file-size size) ""))))
+      (insert-string point
+                     (format nil " ~5@A "
+                             (let ((size (file-size pathname)))
+                               (if size (human-readable-file-size size) "")))
+                     :attribute 'file-size-attribute)
       (multiple-value-bind (second minute hour day month year week)
           (let ((date (file-write-date pathname)))
             (if date
@@ -183,7 +201,8 @@
                        (format nil "~4,'0D/~2,'0D/~2,'0D ~2,'0D:~2,'0D:~2,'0D ~A "
                                year month day hour minute second
                                (if week (aref #("Mon" "Tue" "Wed" "Thr" "Fri" "Sat" "Sun") week)
-                                   "   "))))
+                                   "   "))
+                       :attribute 'file-date-attribute))
       (unless (string= name "..")
         (insert-icon point name))
       (insert-string point
@@ -193,37 +212,38 @@
       (when (symbolic-link-p pathname)
         (insert-string point (format nil " -> ~A" (probe-file pathname))))
       (back-to-indentation start)
-      (put-text-property
-       start
-       point
-       :hover-callback (lambda (window dest-point)
-                         (let* ((src-point (buffer-point (window-buffer window))))
-                           (move-point src-point dest-point)
-                           (update-line src-point t))))
-      (put-text-property
-       start
-       point
-       :click-callback
-       (lambda (window dest-point)
-         (declare (ignore dest-point))
-         (setf (current-window) window)
-         (directory-mode-find-file)))
-      (insert-character point #\newline))))
+      (lem/button:apply-button-between-points
+       start point
+       (lambda ()
+         (lem/button:with-context ()
+           (directory-mode-find-file))))
+      (insert-character point #\newline)
+      (put-text-property start point :read-only t))))
+
+(defun insert-directories-and-files (point
+                                     directory
+                                     &key (sort-method *default-sort-method*)
+                                          (without-parent-directory t))
+  (unless without-parent-directory
+    (alexandria:when-let (pathname (probe-file (merge-pathnames "../" directory)))
+      (insert-pathname point pathname directory "..")))
+  (dolist (pathname (list-directory directory :sort-method sort-method))
+    (insert-pathname point pathname directory)))
 
 (defun update (buffer &key (sort-method *default-sort-method*))
   "Update this directory buffer content."
   (with-buffer-read-only buffer nil
-    (let* ((directory (buffer-directory buffer))
-           (p (buffer-point buffer))
-           (line-number (line-number-at-point p)))
-      (erase-buffer buffer)
-      (buffer-start p)
-      (insert-string p (format nil "~A~2%" directory))
-      (alexandria:when-let (pathname (probe-file (merge-pathnames "../" directory)))
-        (insert-pathname p pathname directory ".."))
-      (dolist (pathname (list-directory directory :sort-method sort-method))
-        (insert-pathname p pathname directory))
-      (move-to-line p line-number))))
+    (let ((*inhibit-read-only* t))
+      (let* ((directory (buffer-directory buffer))
+             (p (buffer-point buffer))
+             (line-number (line-number-at-point p)))
+        (erase-buffer buffer)
+        (buffer-start p)
+        (insert-string p (format nil "~A~2%" directory) :attribute 'current-directory-attribute)
+        (insert-directories-and-files p directory
+                                      :sort-method sort-method
+                                      :without-parent-directory nil)
+        (move-to-line p line-number)))))
 
 (defun update-all ()
   (dolist (buffer (buffer-list))

src/mouse.lisp

@@ -345,6 +345,10 @@
       (delete-overlay overlay)
       (setf (buffer-value buffer :unhover-callback) nil))))
 
+(defun clear-buffer-hover-overlay-when-before-change (point arg)
+  (declare (ignore arg))
+  (clear-buffer-hover-overlay (point-buffer point)))
+
 (defun update-hover-overlay (point)
   (let ((buffer (point-buffer point)))
     (with-point ((start point)
@@ -358,6 +362,8 @@
                (move-point (overlay-end overlay) end))
               (t
                (let ((overlay (make-overlay start end 'region)))
+                 (add-hook (variable-value 'before-change-functions :buffer buffer)
+                           'clear-buffer-hover-overlay-when-before-change)
                  (setf (buffer-value buffer :unhover-callback)
                        (lambda (window point)
                          (declare (ignore window point))