diff --git a/modes/lisp-mode/repl.lisp b/modes/lisp-mode/repl.lisp index 0354495a3..37df8286c 100644 --- a/modes/lisp-mode/repl.lisp +++ b/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))) diff --git a/src/ext/directory-mode.lisp b/src/ext/directory-mode.lisp index 172f9ec19..0861dcd89 100644 --- a/src/ext/directory-mode.lisp +++ b/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)) diff --git a/src/mouse.lisp b/src/mouse.lisp index 812f2176e..33377edf2 100644 --- a/src/mouse.lisp +++ b/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))