From c178ad8735594a445a9ef461655cd8c6bb7b64d1 Mon Sep 17 00:00:00 2001 From: vindarel Date: Wed, 3 Jan 2024 22:26:43 +0100 Subject: [PATCH 1/2] legit/porcelain: avoid coupling to Lem when calling asdf:find-system --- extensions/legit/porcelain.lisp | 3 +++ 1 file changed, 3 insertions(+) diff --git a/extensions/legit/porcelain.lisp b/extensions/legit/porcelain.lisp index 9e5d4ec29..52dd6c38b 100644 --- a/extensions/legit/porcelain.lisp +++ b/extensions/legit/porcelain.lisp @@ -614,9 +614,12 @@ M src/ext/porcelain.lisp ;; Save our script as a string at compile time. (defparameter *rebase-script-content* + #+(or lem-ncurses lem-sdl2) (str:from-file (asdf:system-relative-pathname (asdf:find-system "lem") "scripts/dumbrebaseeditor.sh")) + #-(or lem-ncurses lem-sdl2) + "" "Our dumb editor shell script, saved as a string at compile time. We then save it to the user's ~/.lem/legit/rebaseetidor.sh at first use.") From 19f254145f5d7aa14dbbf7c261b9a11405d8b5db Mon Sep 17 00:00:00 2001 From: vindarel Date: Wed, 3 Jan 2024 21:58:30 +0100 Subject: [PATCH 2/2] legit: transform porcelain errors to lem:editor-error and avoid tight coupling between porcelain and lem. > ERROR is treated as an editor bug when the command loop catches it. --- extensions/legit/legit.lisp | 32 ++++++++++++++------- extensions/legit/porcelain.lisp | 50 ++++++++++++++++++++++----------- 2 files changed, 56 insertions(+), 26 deletions(-) diff --git a/extensions/legit/legit.lisp b/extensions/legit/legit.lisp index 4abaf8421..aae6764d3 100644 --- a/extensions/legit/legit.lisp +++ b/extensions/legit/legit.lisp @@ -122,22 +122,34 @@ Next: (defun last-character (s) (subseq s (- (length s) 2) (- (length s) 1))) +(defun call-with-porcelain-error (function) + (handler-bind ((lem/porcelain:porcelain-error + (lambda (c) + (lem:editor-error (slot-value c 'lem/porcelain::message))))) + (funcall function))) + +(defmacro with-porcelain-error (&body body) + "Handle porcelain errors and turn them into a lem:editor-error." + ;; This helps avoiding tight coupling. + `(call-with-porcelain-error (lambda () ,@body))) + (defun call-with-current-project (function) - (let ((root (lem-core/commands/project:find-root (buffer-directory)))) - (uiop:with-current-directory (root) - (multiple-value-bind (root vcs) - (lem/porcelain:vcs-project-p) - (if root - (let ((lem/porcelain:*vcs* vcs)) - (progn - (funcall function))) - (message "Not inside a version-controlled project?")))))) + (with-porcelain-error () + (let ((root (lem-core/commands/project:find-root (buffer-directory)))) + (uiop:with-current-directory (root) + (multiple-value-bind (root vcs) + (lem/porcelain:vcs-project-p) + (if root + (let ((lem/porcelain:*vcs* vcs)) + (progn + (funcall function))) + (message "Not inside a version-controlled project?"))))))) (defmacro with-current-project (&body body) "Execute body with the current working directory changed to the project's root, find and set the VCS system for this operation. - If no Git directory (or .fossil file) are found, message the user." + If no Git directory (or other supported VCS system) are found, message the user." `(call-with-current-project (lambda () ,@body))) diff --git a/extensions/legit/porcelain.lisp b/extensions/legit/porcelain.lisp index 52dd6c38b..8b4045221 100644 --- a/extensions/legit/porcelain.lisp +++ b/extensions/legit/porcelain.lisp @@ -6,6 +6,7 @@ :proper-list) (:export :*vcs* + :porcelain-error :apply-patch :branches :checkout @@ -81,6 +82,23 @@ Mercurial: For instance, see the legit::with-current-project macro that lexically binds *vcs* for an operation.") +(define-condition porcelain-condition (simple-error) + ()) + +(define-condition porcelain-error (porcelain-condition) + ((message + :initform "" + :initarg :message + :type :string)) + (:report + (lambda (condition stream) + (with-slots (message) condition + (princ message stream))))) + +(defun porcelain-error (message &rest args) + (error 'porcelain-error :message (apply #'format nil message args))) + + (defun git-project-p () "Return t if we find a .git/ directory in the current directory (which should be the project root. Use `lem/legit::with-current-project`)." (values (uiop:directory-exists-p ".git") @@ -182,7 +200,7 @@ allows to learn about the file state: modified, deleted, ignored… " (run-fossil "changes") (cond ((not (zerop code)) - (error (str:join #\newline (list out error)))) + (porcelain-error (str:join #\newline (list out error)))) (t (values out error))))) @@ -194,7 +212,7 @@ allows to learn about the file state: modified, deleted, ignored… " (:git (git-porcelain)) (:fossil (fossil-porcelain)) (:hg (hg-porcelain)) - (t (error "VCS not supported: ~a" *vcs*)))) + (t (porcelain-error "VCS not supported: ~a" *vcs*)))) (defun git-components() "Return 3 values: @@ -295,7 +313,7 @@ allows to learn about the file state: modified, deleted, ignored… " (:git (git-components)) (:fossil (fossil-components)) (:hg (hg-components)) - (t (error "VCS not supported: ~a" *vcs*)))) + (t (porcelain-error "VCS not supported: ~a" *vcs*)))) ;;; @@ -378,7 +396,7 @@ allows to learn about the file state: modified, deleted, ignored… " collect (subseq branch 2 (length branch)))) (defun fossil-branches (&key &allow-other-keys) - (error "not implemented")) + (porcelain-error "not implemented")) (defun git-current-branch () (let ((branches (git-list-branches :sort-by "-creatordate"))) @@ -516,8 +534,8 @@ summary: test (case *vcs* (:git (git-unstage file)) (:hg (hg-unstage file)) - (:fossil (error "unstage not implemented for Fossil.")) - (t (error "VCS not supported: ~a" *vcs*)))) + (:fossil (porcelain-error "unstage not implemented for Fossil.")) + (t (porcelain-error "VCS not supported: ~a" *vcs*)))) (defun git-unstage (file) "Unstage changes to a file." @@ -534,7 +552,7 @@ M src/ext/porcelain.lisp (defun hg-unstage (file) (declare (ignorable file)) ;; no index like git, we'd need to exclude files from the commit with -X ? - (error "no unstage support for Mercurial")) + (porcelain-error "no unstage support for Mercurial")) (defvar *verbose* nil) @@ -581,7 +599,7 @@ M src/ext/porcelain.lisp diff: string." (case *vcs* (:fossil (fossil-apply-patch diff :reverse reverse)) - (:hg (error "applying patch not yet implemented for Mercurial")) + (:hg (porcelain-error "applying patch not yet implemented for Mercurial")) (t (git-apply-patch diff :reverse reverse)))) (defun checkout (branch) @@ -596,7 +614,7 @@ M src/ext/porcelain.lisp (defun push (&rest args) (when args - (error "Our git push command doesn't accept args. Did you mean cl:push ?!!")) + (porcelain-error "Our git push command doesn't accept args. Did you mean cl:push ?!!")) (run-git (list "push"))) ;; @@ -646,7 +664,7 @@ M src/ext/porcelain.lisp :error-output :string :ignore-error-status t) #-unix - (error "lem/legit: our rebase script is only for Unix platforms currently. We need to run a shell script and trap a signal.") + (porcelain-error "lem/legit: our rebase script is only for Unix platforms currently. We need to run a shell script and trap a signal.") (setf *rebase-script-path* script-path)))) (defvar *rebase-pid* nil @@ -673,9 +691,9 @@ M src/ext/porcelain.lisp (defun rebase-interactively (&key from) (case *vcs* (:git (git-rebase-interactively :from from)) - (:hg (error "Interactive rebase not implemented for Mercurial")) - (:fossil (error "No interactive rebase for Fossil.")) - (t (error "Interactive rebase not available for this VCS: ~a" *vcs*)))) + (:hg (porcelain-error "Interactive rebase not implemented for Mercurial")) + (:fossil (porcelain-error "No interactive rebase for Fossil.")) + (t (porcelain-error "Interactive rebase not available for this VCS: ~a" *vcs*)))) (defun git-rebase-interactively (&key from) "Start a rebase session. @@ -690,7 +708,7 @@ M src/ext/porcelain.lisp ;; .git/rebase-merge/git-rebase-merge-todo ;; Beware of C-c ~ lol^^ (when (uiop:directory-exists-p ".git/rebase-merge/") - (error "It seems that there is already a rebase-merge directory, + (porcelain-error "It seems that there is already a rebase-merge directory, and I wonder if you are in the middle of another rebase. If that is the case, please try git rebase (--continue | --abort | --skip) @@ -731,7 +749,7 @@ I am stopping in case you still have something valuable there.")) (values (format nil "rebase started") nil 0)) - (error "git rebase process didn't start properly. Aborting."))) + (porcelain-error "git rebase process didn't start properly. Aborting."))) (setf (uiop:getenv "EDITOR") editor)))) (defun rebase-continue () @@ -754,4 +772,4 @@ I am stopping in case you still have something valuable there.")) "" 0)) (t - (error "No git rebase in process? PID not found.")))) + (porcelain-error "No git rebase in process? PID not found."))))