Merge branch 'main' of github.com:lem-project/lem

extensions/lem-dashboard/dashboard-items.lisp

@@ -0,0 +1,153 @@
+(in-package :lem-dashboard)
+
+;; Splash
+(defclass dashboard-splash (dashboard-item)
+  ((splash-texts :initarg :splash-texts :accessor splash-texts 
+                 :initform '("Welcome!"))
+   (selected-splash :initarg :selected-splash :accessor selected-splash
+                    :initform nil))
+  (:documentation "Randomly displays one of SPLASH-TEXTS")
+  (:default-initargs
+   :item-attribute 'document-text-attribute))
+
+(defmethod draw-dashboard-item ((item dashboard-splash) point)
+  (unless (selected-splash item)
+    (setf (selected-splash item) 
+          (nth (random (length (splash-texts item))) (splash-texts item))))
+  (dolist (line (str:lines (selected-splash item)))
+    (insert-string point (create-centered-string line) :attribute (item-attribute item))
+    (insert-character point #\Newline)))
+
+;; Url
+(defclass dashboard-url (dashboard-item)
+  ((url :initarg :url :accessor url)
+   (display-text :initarg :display-text :accessor display-text))
+  (:documentation "Creates link/button with DISPLAY-TEXT that opens URL externally.")
+  (:default-initargs
+   :item-attribute 'document-text-attribute))
+
+(defmethod initialize-instance :after ((item dashboard-url) &key)
+  (with-slots (url action) item
+    (setf action (lambda () (open-external-file url)))))
+
+(defmethod draw-dashboard-item ((item dashboard-url) point)
+  (button:insert-button point 
+                            (create-centered-string (display-text item))
+                            (lambda () (open-external-file (url item)))
+                            :attribute (item-attribute item)))
+
+;; Working dir
+(defclass dashboard-working-dir (dashboard-item)
+  ()
+  (:documentation "Prints current working directory")
+  (:default-initargs
+   :item-attribute 'document-header4-attribute))
+
+(defmethod draw-dashboard-item ((item dashboard-working-dir) point)
+  (let ((working-dir (format nil "> ~A" (buffer-directory))))
+    (insert-string point (create-centered-string working-dir) :attribute 'document-header4-attribute)
+    (insert-character point #\Newline)))
+
+;; Footer
+(defclass dashboard-footer-message (dashboard-item)
+  ((messages :initarg :messages :accessor messages :initform '("Happy Coding!"))
+   (selected-message :initarg :selected-message :accessor selected-message
+                     :initform nil))
+  (:documentation "Randomly displays one of the passed-in MESSAGES")
+  (:default-initargs
+   :item-attribute 'document-text-attribute))
+
+(defmethod draw-dashboard-item ((item dashboard-footer-message) point)
+  (unless (selected-message item)
+    (setf (selected-message item) 
+          (nth (random (length (messages item))) (messages item))))
+  (insert-string point 
+                 (create-centered-string (format nil "> ~A" (selected-message item))) 
+                 :attribute (item-attribute item)))
+
+;; Command
+(defclass dashboard-command (dashboard-item)
+  ((display-text :initarg :display-text :accessor display-text)
+   (action-command :initarg :action-command :accessor action-command))
+  (:documentation "Creates a link/button with DISPLAY-TEXT that executes ACTION-COMMAND when clicked.")
+  (:default-initargs
+   :item-attribute 'document-text-attribute))
+
+(defmethod initialize-instance :after ((item dashboard-command) &key)
+  (with-slots (action-command action) item
+    (setf action (lambda () (funcall action-command)))))
+
+(defmethod draw-dashboard-item ((item dashboard-command) point)
+  (button:insert-button point 
+                            (create-centered-string (display-text item))
+                            (lambda () (funcall (action-command item)))
+                            :attribute (item-attribute item)))
+
+;; Recent projects
+(defclass dashboard-recent-projects (dashboard-item)
+  ((project-count :initarg :project-count :accessor project-count :initform 5))
+  (:documentation "Displays a list of recent projects, limited to the last PROJECT-COUNT.")
+  (:default-initargs
+   :item-attribute 'document-text-attribute
+   :action (lambda ()
+             (let ((project (str:trim (line-string (current-point)))))
+               (when project
+                 (uiop:with-current-directory (project)
+                   (project:project-find-file project)))))))
+
+(define-command dashboard-move-to-recent-projects () ()
+  (let ((point (buffer-point (current-buffer))))
+    (buffer-start point)
+    (search-forward-regexp point "Recent Projects")
+    (line-offset point 2)
+    (move-to-beginning-of-line)))
+
+(defmethod draw-dashboard-item ((item dashboard-recent-projects) point)
+  (let* ((title (format nil "~A Recent Projects (r)" (icon-string "package")))
+         (title-line (create-centered-string title)))
+    (insert-string point title-line :attribute 'document-header1-attribute)
+    (insert-character point #\Newline)
+    (insert-character point #\Newline)
+    (let* ((projects (reverse (project:saved-projects)))
+           (display-projects (subseq projects 0 (min (project-count item) (length projects)))))
+      (when display-projects
+          (let* ((longest-project (reduce #'(lambda (a b) (if (> (length a) (length b)) a b)) display-projects))
+                 (max-length (length longest-project))
+                 (left-padding (floor (- (window-width (current-window)) max-length) 2)))
+            (loop for project in display-projects
+                  do (insert-string point (format nil "~v@{~A~:*~}" left-padding " "))
+                     (insert-string point (format nil "~A~%" project))))))))
+
+;; Recent files
+(defclass dashboard-recent-files (dashboard-item)
+  ((file-count :initarg :file-count :accessor file-count :initform 5))
+  (:documentation "Displays a list of recent files, limited to the last FILE-COUNT.")
+  (:default-initargs
+   :item-attribute 'document-text-attribute
+   :action (lambda ()
+             (let ((file (str:trim (line-string (current-point)))))
+               (when file
+                 (find-file file))))))
+
+(define-command dashboard-move-to-recent-files () ()
+  (let ((point (buffer-point (current-buffer))))
+    (buffer-start point)
+    (search-forward-regexp point "Recent Files")
+    (line-offset point 2)
+    (move-to-beginning-of-line)))
+
+(defmethod draw-dashboard-item ((item dashboard-recent-files) point)
+  (let* ((title (format nil "~A Recent Files (f)" (icon-string "file-text")))
+         (title-line (create-centered-string title))
+         (recent-files (reverse (history:history-data-list (file:file-history)))))
+    (insert-string point title-line :attribute 'document-header1-attribute)
+    (insert-character point #\Newline)
+    (insert-character point #\Newline)
+    (let ((display-files (subseq recent-files 0 (min (file-count item) (length recent-files)))))
+      (when display-files
+          (let* ((longest-file (reduce #'(lambda (a b) (if (> (length a) (length b)) a b)) display-files))
+                 (max-length (length longest-file))
+                 (left-padding (floor (- (window-width (current-window)) max-length) 2)))
+            (loop for file in display-files
+                  do (insert-string point (str:fit left-padding " "))
+                     (insert-string point (format nil "~A~%" file))))))))

extensions/lem-dashboard/default-dashboard.lisp

@@ -0,0 +1,86 @@
+(in-package :lem-dashboard)
+
+(defvar *default-footer-messages* '("Happy Coding!"
+                                    "ほげほげ"
+                                    "In Lisp we trust, for bugs we adjust"
+                                    "Read, Evaluate, Print, Love"
+                                    "May your parentheses always be balanced"
+                                    "(setf productivity 'high)"
+                                    "<M-x> load-library <RET> tetris"
+                                    "Lem Editor Modules? Lisp EMacs? Lem's Not Emacs?"
+                                    "(cons 'fun 'programming)"))
+
+(defvar *default-splash* '("
+ ----------------------- 
+ [   Welcome to Lem!   ] 
+ ----------------------- 
+
+       #+====-===        
+    ##+-----------=      
+  ########**==------=    
+ ##########  %-------=   
+%#########+==-:---=====  
+########:::::::::::+  =  
+######*=++-::::::::::    
+#########=::::           
+%#######*:::::           
+ #######+:::::::         
+  %######=:::::::::      
+    #######*-::::        
+       %##*-:::::        
+"))
+
+(define-command open-lem-docs () ()
+  (open-external-file "https://lem-project.github.io/usage/usage/"))
+
+(define-command open-lem-github () ()
+  (open-external-file "https://github.com/lem-project/lem"))
+
+(defun set-default-dashboard (&key 
+                              (project-count 5)
+                              (file-count 5)
+                              (splash *default-splash*)
+                              (footer-messages *default-footer-messages*)
+                              hide-links)
+  (let ((dashboard-items 
+          (list (make-instance 'dashboard-splash
+                               :item-attribute 'document-metadata-attribute
+                               :splash-texts splash)
+                (make-instance 'dashboard-working-dir)
+                (make-instance 'dashboard-recent-projects 
+                               :project-count project-count
+                               :bottom-margin 1)
+                (make-instance 'dashboard-recent-files 
+                               :file-count file-count
+                               :bottom-margin 1)
+                (make-instance 'dashboard-command
+                               :display-text " New Lisp Scratch Buffer (l)"
+                               :action-command 'lem-lisp-mode:lisp-scratch
+                               :item-attribute 'document-header2-attribute
+                               :bottom-margin 2))))
+    (unless hide-links
+      (setf dashboard-items
+            (append dashboard-items
+                    (list (make-instance 'dashboard-url 
+                                         :display-text " Getting Started (s)"
+                                         :url "https://lem-project.github.io/usage/usage/"
+                                         :item-attribute 'document-header3-attribute)
+                          (make-instance 'dashboard-url
+                                         :display-text " GitHub (g)"
+                                         :url "https://github.com/lem-project/lem"
+                                         :item-attribute 'document-header3-attribute
+                                         :bottom-margin 2)))))
+    (setf dashboard-items
+          (append dashboard-items
+                  (list (make-instance 'dashboard-footer-message 
+                                       :item-attribute 'document-blockquote-attribute
+                                       :messages footer-messages))))
+    (set-dashboard dashboard-items)))
+
+(define-key *dashboard-mode-keymap* "s" 'open-lem-docs)
+(define-key *dashboard-mode-keymap* "g" 'open-lem-github)
+(define-key *dashboard-mode-keymap* "r" 'dashboard-move-to-recent-projects)
+(define-key *dashboard-mode-keymap* "f" 'dashboard-move-to-recent-files)
+(define-key *dashboard-mode-keymap* "l" 'lem-lisp-mode/internal:lisp-scratch)
+
+(set-default-dashboard)

extensions/lem-dashboard/lem-dashboard.asd

@@ -0,0 +1,6 @@
+(defsystem "lem-dashboard"
+  :depends-on (:lem)
+  :serial t
+  :components ((:file "lem-dashboard")
+               (:file "dashboard-items")
+               (:file "default-dashboard")))

extensions/lem-dashboard/lem-dashboard.lisp

@@ -0,0 +1,131 @@
+(defpackage :lem-dashboard
+  (:use :cl :lem)
+  (:export :open-dashboard
+           :*dashboard-mode-keymap*
+           :*dashboard-enable*
+           :dashboard-move-to-recent-projects
+           :dashboard-move-to-recent-files
+           :set-dashboard
+           :set-default-dashboard
+           :create-centered-string)
+  (:local-nicknames (:button :lem/button)
+                    (:history :lem/common/history)
+                    (:project :lem-core/commands/project)
+                    (:file :lem-core/commands/file)))
+
+(in-package :lem-dashboard)
+
+(defvar *dashboard-buffer-name* "*dashboard*")
+(defvar *dashboard-enable* t)
+(defvar *dashboard-mode-keymap* (make-keymap :name '*dashboard-mode-keymap* :parent *global-keymap*))
+(defvar *dashboard-layout* nil
+  "List of dashboard-item instances; will be drawn in order.")
+
+(defun create-centered-string (str)
+  "Creates a 'centered' string by padding with space to fill the screen width halfway."
+  (let* ((padding (max 0 (floor (- (window-width (current-window)) (length str)) 2)))
+         (spaces (make-string padding :initial-element #\Space)))
+    (concatenate 'string spaces str)))
+
+(defclass dashboard-item ()
+  ((item-attribute 
+    :initarg :item-attribute 
+    :accessor item-attribute 
+    :initform 'document-text-attribute
+    :documentation "Attribute to use when drawing this item.")
+   (top-margin
+    :initarg :top-margin 
+    :accessor top-margin
+    :initform 0
+    :documentation "The amount of vertical space (lines) to apply before the item.")
+   (bottom-margin
+    :initarg :bottom-margin 
+    :accessor bottom-margin
+    :initform 1
+    :documentation "The amount of vertical space (lines) to apply after the item.")
+   (action 
+    :initarg :action 
+    :accessor action 
+    :initform nil
+    :documentation "Function to execute when <return> is pressed over this item."))
+  (:documentation "Base class for all dashboard items."))
+
+(defgeneric draw-dashboard-item (item point)
+  (:documentation "Called to draw the dashboard item.")
+  (:method :before ((item dashboard-item) point)
+    (dotimes (i (top-margin item))
+      (insert-character point #\Newline)))
+  (:method :after ((item dashboard-item) point)
+    (dotimes (i (bottom-margin item))
+      (insert-character point #\Newline))))
+
+(define-command dashboard-open-selected-item () ()
+  "Execute action on selected dashboard item."
+  (let* ((point (current-point))
+         (item (text-property-at point :dashboard-item)))
+    (when (and item (action item))
+      (funcall (action item)))))
+
+(defmethod draw-dashboard-item :around ((item dashboard-item) point)
+  "Inserts a :dashboard-item text property in between the starting and ending POINT, useful for tracking."
+  (let ((start (copy-point point :temporary)))
+    (call-next-method)
+    (let ((end (copy-point point :temporary)))
+      (put-text-property start end :dashboard-item item)
+      (delete-point start)
+      (delete-point end))))
+
+(define-major-mode dashboard-mode ()
+    (:name "Dashboard"
+     :keymap *dashboard-mode-keymap*))
+
+(defun create-dashboard-buffer ()
+  "Creates the dashboard buffer."
+  (or (get-buffer *dashboard-buffer-name*)
+      (make-buffer *dashboard-buffer-name*
+                   :enable-undo-p nil
+                   :read-only-p t)))
+
+(defun redraw-dashboard ()
+  "Redraws the dashboard, clearing and redrawing all content while attempting to maintain point position."
+  (let* ((buffer (create-dashboard-buffer))
+         (old-line (line-number-at-point (buffer-point buffer)))
+         (old-column (point-column (buffer-point buffer))))
+    (with-buffer-read-only buffer nil
+      (erase-buffer buffer)
+      (let ((point (buffer-point buffer)))
+        (dolist (item *dashboard-layout*)
+          (draw-dashboard-item item point)))
+      (change-buffer-mode buffer 'dashboard-mode)
+      (move-to-line (buffer-point buffer) old-line)
+      (move-to-column (buffer-point buffer) old-column))))
+
+(define-command open-dashboard () ()
+  "Opens the dashboard if it doesn't exist, or switches to it if it does."
+  (when *dashboard-enable*
+    (if (get-buffer *dashboard-buffer-name*)
+        (switch-to-buffer (get-buffer *dashboard-buffer-name*))
+        (progn
+          (redraw-dashboard)
+          (switch-to-buffer (get-buffer *dashboard-buffer-name*))))))
+
+(defun set-dashboard (dashboard-items)
+  "Sets the new dashboard layout to DASHBOARD-ITEMS list and applies new keymap."
+  (when dashboard-items
+    (setf *dashboard-layout* dashboard-items)
+    (when (get-buffer *dashboard-buffer-name*)
+      (redraw-dashboard))))
+
+(defun handle-resize (window)
+  "Handle resizing; in this case, redraw the dashboard to keep it centered."
+  (when (string= (buffer-name (window-buffer window)) *dashboard-buffer-name*)
+    (redraw-dashboard)))
+
+(define-key *dashboard-mode-keymap* "n" 'next-line)
+(define-key *dashboard-mode-keymap* "p" 'previous-line)
+(define-key *dashboard-mode-keymap* "j" 'next-line)
+(define-key *dashboard-mode-keymap* "k" 'previous-line)
+(define-key *dashboard-mode-keymap* "Return" 'dashboard-open-selected-item)
+
+(setf lem:*splash-function* #'open-dashboard)
+(add-hook *window-size-change-functions* 'handle-resize)

extensions/lisp-mode/internal-package.lisp

@@ -41,6 +41,7 @@
    :with-remote-eval
    :lisp-eval-from-string
    :lisp-eval
+   :lisp-scratch
    :lisp-eval-async
    :eval-with-transcript
    :re-eval-defvar

lem.asd

@@ -260,7 +260,8 @@
                "lem-color-preview"
                "lem-lua-mode"
                "lem-terminal"
-               "lem-legit"))
+               "lem-legit"
+               "lem-dashboard"))
 
 (defsystem "lem/executable"
   :build-operation program-op