├── Resource ├── src │ ├── application. │ ├── views.lisp │ ├── debugger.lisp │ ├── thread.lisp │ ├── frame.lisp │ └── application.lisp └── mcclim-desktop-resource.asd ├── dot-mcclim-desktop ├── config │ ├── localhost:3000 │ ├── gsharp-config.lisp │ ├── clim-demo-config.lisp │ ├── climon-config.lisp │ ├── sudoku-config.lisp │ ├── ernestine-config.lisp │ ├── pkg-doc-config.lisp │ ├── swank-server-config.lisp │ ├── scigraph-config.lisp │ ├── scliba-config.lisp │ ├── spectacle-config.lisp │ ├── 2048-config.lisp │ ├── chess-config.lisp │ ├── clouseau-config.lisp │ ├── climc-config.lisp │ ├── console-config.lisp │ ├── dired-config.lisp │ ├── launcher-config.lisp │ ├── mastodon-config.lisp │ ├── maxima-config.lisp │ ├── task-manager-config.lisp │ ├── app-manager-config.lisp │ ├── apropos-navigator-config.lisp │ ├── kirc-config.lisp │ ├── _%sample_-config.lisp │ ├── mcclide-config.lisp │ ├── class-browser-config.lisp │ ├── closure-config.lisp │ ├── system-browser-config.lisp │ ├── desktop-debugger-config.lisp │ ├── clim-debugger-config.lisp │ ├── swank-debugger-config.lisp │ ├── listener-config.lisp │ ├── beirc-config.lisp │ └── climacs-config.lisp ├── init.lisp ├── apps │ ├── emacs.lisp │ ├── scigraph.lisp │ ├── slime.lisp │ ├── kirc.lisp │ ├── beirc.lisp │ ├── climc.lisp │ ├── closure.lisp │ ├── browser.lisp │ ├── climon.lisp │ ├── ernestine.lisp │ ├── 2048.lisp │ ├── swank-server.lisp │ ├── gsharp.lisp │ ├── mastodon.lisp │ ├── mcclide.lisp │ ├── spectacle.lisp │ ├── climacs.lisp │ ├── maxima.lisp │ ├── sudoku.lisp │ ├── swank-debugger.lisp │ ├── chess.lisp │ ├── dired.lisp │ ├── pkg-doc.lisp │ ├── clim-demo.lisp │ ├── editor.lisp │ ├── listener.lisp │ ├── clim-debugger.lisp │ ├── class-browser.lisp │ ├── scliba.lisp │ ├── console.lisp │ ├── launcher.lisp │ ├── task-manager.lisp │ ├── clouseau.lisp │ ├── app-manager.lisp │ ├── system-browser.lisp │ ├── apropos-navigator.lisp │ ├── desktop-debugger.lisp │ └── _%sample_.lisp └── config.lisp ├── Apps ├── app-manager │ ├── gui │ │ ├── presentations.lisp │ │ ├── main.lisp │ │ ├── commands.lisp │ │ └── frame.lisp │ ├── doc │ │ └── img │ │ │ └── screenshot-01.jpg │ ├── packages.lisp │ ├── README.org │ └── mcclim-desktop-app-manager.asd ├── task-manager │ ├── gui │ │ ├── parameters.lisp │ │ ├── main.lisp │ │ ├── commands.lisp │ │ └── frame.lisp │ ├── doc │ │ └── img │ │ │ └── screenshot-01.jpg │ ├── mcclim-desktop-task-manager.lisp │ ├── README.org │ └── mcclim-desktop-task-manager.asd ├── launcher │ ├── gui │ │ ├── presentations.lisp │ │ ├── parameters.lisp │ │ ├── utility.lisp │ │ ├── main.lisp │ │ ├── commands.lisp │ │ └── frame.lisp │ ├── doc │ │ └── img │ │ │ └── screenshot-01.jpg │ ├── packages.lisp │ ├── README.org │ └── mcclim-desktop-launcher.asd ├── apropos │ ├── doc │ │ └── img │ │ │ └── screenshot-01.jpg │ ├── README.org │ ├── mcclim-desktop-apropos.lisp │ ├── mcclim-desktop-apropos.asd │ ├── gui │ │ ├── parameters.lisp │ │ ├── main.lisp │ │ ├── commands.lisp │ │ └── frame.lisp │ └── src │ │ ├── iapropos-preselects.lisp │ │ ├── presentations.lisp │ │ ├── utility.lisp │ │ └── iapropos.lisp ├── console │ ├── doc │ │ └── img │ │ │ └── screenshot-01.jpg │ ├── packages.lisp │ ├── README.org │ ├── gui │ │ ├── main.lisp │ │ ├── wholine.lisp │ │ ├── commands.lisp │ │ └── frame.lisp │ └── mcclim-desktop-console.asd ├── debugger │ ├── doc │ │ └── img │ │ │ └── screenshot-01.jpg │ ├── src │ │ ├── mcclim-desktop-debugger.lisp │ │ └── debugger.lisp │ ├── README.org │ └── mcclim-desktop-debugger.asd ├── packages.lisp └── mcclim-desktop-apps.asd ├── .gitignore ├── init.lisp ├── Sys ├── src │ ├── kill-ring.lisp │ ├── clipboard.lisp │ └── screenshot.lisp └── mcclim-desktop-sys.asd ├── Core ├── src │ ├── init.lisp │ ├── application-discovery.lisp │ ├── debugger.lisp │ ├── standard-application.lisp │ ├── applications.lisp │ ├── api.lisp │ ├── logger.lisp │ ├── application-mixins.lisp │ ├── standard-pathnames.lisp │ └── application.lisp └── mcclim-desktop-core.asd ├── mcclim-desktop.asd ├── roswell └── mcclim-desktop.ros ├── packages.lisp └── README.org /Resource/src/application.: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/localhost:3000: -------------------------------------------------------------------------------- 1 | 42461 2 | -------------------------------------------------------------------------------- /Apps/app-manager/gui/presentations.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-app-manager) 2 | -------------------------------------------------------------------------------- /Apps/task-manager/gui/parameters.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-task-manager) 2 | -------------------------------------------------------------------------------- /Apps/launcher/gui/presentations.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-launcher) 2 | 3 | 4 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.fasl 2 | *.dx32fsl 3 | *.dx64fsl 4 | *.lx32fsl 5 | *.lx64fsl 6 | *.x86f 7 | *~ 8 | .#* -------------------------------------------------------------------------------- /init.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | ;; initialize the desktop environment 4 | (initialize) 5 | -------------------------------------------------------------------------------- /Apps/apropos/doc/img/screenshot-01.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gas2serra/mcclim-desktop/HEAD/Apps/apropos/doc/img/screenshot-01.jpg -------------------------------------------------------------------------------- /Apps/console/doc/img/screenshot-01.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gas2serra/mcclim-desktop/HEAD/Apps/console/doc/img/screenshot-01.jpg -------------------------------------------------------------------------------- /Apps/debugger/doc/img/screenshot-01.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gas2serra/mcclim-desktop/HEAD/Apps/debugger/doc/img/screenshot-01.jpg -------------------------------------------------------------------------------- /Apps/launcher/doc/img/screenshot-01.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gas2serra/mcclim-desktop/HEAD/Apps/launcher/doc/img/screenshot-01.jpg -------------------------------------------------------------------------------- /Apps/app-manager/doc/img/screenshot-01.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gas2serra/mcclim-desktop/HEAD/Apps/app-manager/doc/img/screenshot-01.jpg -------------------------------------------------------------------------------- /Apps/task-manager/doc/img/screenshot-01.jpg: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/gas2serra/mcclim-desktop/HEAD/Apps/task-manager/doc/img/screenshot-01.jpg -------------------------------------------------------------------------------- /dot-mcclim-desktop/init.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (use-logger (make-logger 'standard-logger)) 4 | (install-debugger-globally) 5 | -------------------------------------------------------------------------------- /Apps/console/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage desktop-console 4 | (:use :desktop :desktop-extensions :cl) 5 | (:export 6 | :run-console)) 7 | 8 | (in-package :desktop-console) 9 | -------------------------------------------------------------------------------- /Apps/launcher/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage desktop-launcher 4 | (:use :desktop :desktop-extensions :cl) 5 | (:export 6 | :run-launcher)) 7 | 8 | (in-package :desktop-launcher) 9 | -------------------------------------------------------------------------------- /Apps/app-manager/packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage desktop-app-manager 4 | (:use :desktop :desktop-extensions :cl) 5 | (:export 6 | :run-app-manager)) 7 | 8 | (in-package :desktop-app-manager) 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/gsharp-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (gsharp:gsharp))) 7 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/clim-demo-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (clim-demo::demodemo))) 7 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/climon-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (climon:climon))) 7 | 8 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/sudoku-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (sudoku-mcclim:run))) 7 | 8 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/ernestine-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (ernestine-gui:player))) 7 | -------------------------------------------------------------------------------- /Apps/console/README.org: -------------------------------------------------------------------------------- 1 | * Console (mcclim-desktop) 2 | 3 | #+CAPTION: Screenshot 4 | #+NAME: fig:screenshot 5 | [[./doc/img/screenshot-01.jpg]] 6 | 7 | 8 | ** Usage 9 | 10 | ** Installation 11 | 12 | ** Keystroke 13 | 14 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/pkg-doc-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (clim-pkg-doc:pkg-doc))) 7 | 8 | 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/swank-server-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app)) 6 | (swank:create-server :style nil))) 7 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/scigraph-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (graph:make-demo-frame))) 7 | 8 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/scliba-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app object &rest args) 5 | (declare (ignore app)) 6 | (scliba-gui:scliba-gui))) 7 | 8 | 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/spectacle-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (spectacle:spectacle))) 7 | 8 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/2048-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (2048-mcclim:run))) 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/chess-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (clim-chess:chess))) 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/clouseau-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app object &rest args) 5 | (declare (ignore app)) 6 | (clouseau:inspector object))) 7 | 8 | 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/climc-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (climc:start-climc))) 7 | 8 | 9 | 10 | 11 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/console-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (application &rest args) 5 | (declare (ignore application args)) 6 | (desktop-console:run-console))) 7 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/dired-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (ftd:ftd *DEFAULT-PATHNAME-DEFAULTS*))) 7 | 8 | 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/launcher-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (application &rest args) 5 | (declare (ignore application args)) 6 | (desktop-launcher:run-launcher))) 7 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/mastodon-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (mastodon-gui:mastodon-gui))) 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/maxima-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (maxima-clinet:maxima-client))) 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/task-manager-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (desktop-apps:run-task-manager))) 7 | 8 | 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/emacs.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "emacs" 'standard-shell-application 4 | :pretty-name "Emacs" 5 | :make-command-fn #'(lambda (&rest args) 6 | (format nil "emacs ~{~A ~}" args))) 7 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/app-manager-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (application &rest args) 5 | (declare (ignore application args)) 6 | (desktop-app-manager:run-app-manager))) 7 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/apropos-navigator-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app) 5 | (declare (ignore app)) 6 | (desktop-apps:run-apropos-navigator))) 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /Apps/launcher/gui/parameters.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-launcher) 2 | 3 | (defvar *applications* nil) 4 | 5 | (defun update-applications () 6 | (setf *applications* 7 | (sort (applications) 8 | #'string< 9 | :key #'application-pretty-name))) 10 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/kirc-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (kirc:start-kirc "mcclim-dekstop" ""))) 7 | 8 | 9 | 10 | -------------------------------------------------------------------------------- /Apps/debugger/src/mcclim-desktop-debugger.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage desktop-debugger 4 | (:use :cl :desktop :desktop-extensions) 5 | (:import-from :clim 6 | ) 7 | (:export 8 | :debugger 9 | )) 10 | 11 | (in-package :desktop-debugger) 12 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/_%sample_-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | ;;; 4 | ;;; Examples 5 | ;;; 6 | 7 | #| 8 | (setf (application-entry-fn *application*) 9 | #'(lambda (app &rest args) 10 | (declare (ignore app args)) 11 | nil)) 12 | 13 | |# 14 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/mcclide-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (defun mcclide-entry-fn (application &rest args) 4 | (declare (ignore application args)) 5 | (mcclide:mcclide)) 6 | 7 | (setf (application-entry-fn *application*) #'mcclide-entry-fn) 8 | 9 | 10 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/scigraph.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "scigraph" 'standard-mcclim-application 4 | :pretty-name "Sci Graph" 5 | :icon nil 6 | :home-page "https://github.com/robert-strandh/McCLIM" 7 | :system-name "scigraph") 8 | -------------------------------------------------------------------------------- /Apps/task-manager/mcclim-desktop-task-manager.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage desktop-task-manager 4 | (:use :desktop :desktop-extensions :cl) 5 | (:import-from :clim 6 | ) 7 | (:export 8 | :run-task-manager 9 | )) 10 | 11 | (in-package :desktop-task-manager) 12 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/class-browser-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (clim-class-browser:browse-class 'clim:sheet))) 7 | 8 | 9 | 10 | 11 | 12 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/slime.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "slime" 'standard-shell-application 4 | :pretty-name "Slime" 5 | :make-command-fn #'(lambda (&rest args) 6 | (declare (ignore args)) 7 | (format nil "emacs --eval '(slime-connect \"127.0.0.1\" 4005)'"))) 8 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/kirc.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "kirc" 'standard-mcclim-application 4 | :pretty-name "Kirk" 5 | :icon nil 6 | :home-page "https://github.com/knusbaum/KIRC" 7 | :git-repo "https://github.com/knusbaum/KIRC.git" 8 | :system-name "kirc") 9 | -------------------------------------------------------------------------------- /Sys/src/kill-ring.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-sys) 2 | 3 | (defun copy-to-kill-ring (string) 4 | (drei-kill-ring:kill-ring-standard-push 5 | drei-kill-ring:*kill-ring* 6 | string)) 7 | 8 | (defun paste-from-kill-ring () 9 | (coerce (drei-kill-ring:kill-ring-yank 10 | drei-kill-ring:*kill-ring*) 11 | 'string)) 12 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/beirc.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "beirc" 'standard-mcclim-application 4 | :pretty-name "Be IRC" 5 | :icon nil 6 | :home-page "https://github.com/MrNeutron/beirc" 7 | :git-repo "https://github.com/MrNeutron/beirc.git" 8 | :system-name "beirc") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/climc.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "climc" 'standard-mcclim-application 4 | :pretty-name "Climc" 5 | :icon nil 6 | :home-page "https://github.com/nlamirault/climc" 7 | :git-repo "https://github.com/nlamirault/climc.git" 8 | :system-name "climc") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/closure.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "closure" 'standard-mcclim-application 4 | :pretty-name "Closure" 5 | :icon nil 6 | :home-page "https://github.com/dym/closure" 7 | :git-repo "https://github.com/dym/closure.git" 8 | :system-name "closure") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/browser.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "browser" 'standard-alias-application 4 | :pretty-name "Browser" 5 | :icon nil 6 | ;;:reference (find-application "closure") 7 | :reference (find-application "system-browser") 8 | ) 9 | 10 | 11 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/climon.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "climon" 'standard-mcclim-application 4 | :pretty-name "Climon" 5 | :icon nil 6 | :home-page "https://github.com/nlamirault/climon" 7 | :git-repo "https://github.com/nlamirault/climon.git" 8 | :system-name "climon") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/ernestine.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "ernestine" 'standard-mcclim-application 4 | :pretty-name "Ernestine" 5 | :system-name "ernestine-gui" 6 | :home-page "https://github.com/nlamirault/ernestine" 7 | :git-repo "https://github.com/nlamirault/ernestine.git") 8 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/2048.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "2048" 'standard-mcclim-application 4 | :pretty-name "2048" 5 | :icon nil 6 | :home-page "https://github.com/TeMPOraL/2048-mcclim" 7 | :git-repo "https://github.com/TeMPOraL/2048-mcclim.git" 8 | :system-name "2048-mcclim") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/swank-server.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "swank-server" 'standard-cl-application 4 | :pretty-name "Swank Server" 5 | :icon nil 6 | :menu-p t 7 | :requires-args-p nil 8 | :home-page "" 9 | :git-repo "" 10 | :system-name "swank") 11 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/gsharp.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "gsharp" 'standard-mcclim-application 4 | :pretty-name "Gsharp" 5 | :icon nil 6 | :home-page "https://github.com/informatimago/gsharp" 7 | :git-repo "https://github.com/informatimago/gsharp.git" 8 | :system-name "gsharp") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/mastodon.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "mastodon" 'standard-mcclim-application 4 | :pretty-name "Mastodon" 5 | :icon nil 6 | :home-page "https://github.com/lokedhs/mastodon" 7 | :git-repo "https://github.com/lokedhs/mastodon.git" 8 | :system-name "mastodon") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/mcclide.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "mcclide" 'standard-mcclim-application 4 | :pretty-name "Mcclim IDE" 5 | :icon nil 6 | :home-page "https://github.com/gas2serra/mcclide" 7 | :git-repo "https://github.com/gas2serra/mcclide.git" 8 | :system-name "mcclide") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/spectacle.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "spectacle" 'standard-mcclim-application 4 | :pretty-name "Spectacle" 5 | :icon nil 6 | :home-page "https://github.com/slyrus/spectacle" 7 | :git-repo "https://github.com/slyrus/spectacle.git" 8 | :system-name "spectacle") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/closure-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (closure:start) 7 | (bt:join-thread clim-gui::*closure-process*))) 8 | 9 | (setf gui:*home-page* "http://www.cliki.net/") 10 | 11 | 12 | 13 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/climacs.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "climacs" 'standard-mcclim-application 4 | :pretty-name "Climacs" 5 | :icon nil 6 | :home-page "https://github.com/robert-strandh/Climacs" 7 | :git-repo "https://github.com/robert-strandh/Climacs.git" 8 | :system-name "climacs") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/maxima.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "maxima" 'standard-mcclim-application 4 | :pretty-name "Maxima" 5 | :icon nil 6 | :home-page "https://github.com/lokedhs/maxima-client" 7 | :git-repo "https://github.com/lokedhs/maxima-client.git" 8 | :system-name "maxima-client") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/sudoku.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "sudoku" 'standard-mcclim-application 4 | :pretty-name "Sudoku" 5 | :icon nil 6 | :home-page "https://github.com/tortkis/sudoku-mcclim" 7 | :git-repo "https://github.com/tortkis/sudoku-mcclim.git" 8 | :system-name "sudoku-mcclim") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/swank-debugger.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "swank-debugger" 'standard-debugger-application 4 | :pretty-name "Swank Debugger" 5 | :icon nil 6 | :menu-p nil 7 | :requires-args-p t 8 | :home-page "" 9 | :git-repo "" 10 | :system-name "swank") 11 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/chess.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "chess" 'standard-mcclim-application 4 | :pretty-name "Chess" 5 | :icon nil 6 | :home-page "https://github.com/stassats/clim-chess" 7 | :git-repo "https://github.com/stassats/clim-chess.git" 8 | :system-name "clim-chess") 9 | 10 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/dired.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "dired" 'standard-mcclim-application 4 | :pretty-name "Dired" 5 | :icon nil 6 | :home-page "https://github.com/gas2serra/flexi-trivial-dired" 7 | :git-repo "https://github.com/gas2serra/flexi-trivial-dired.git" 8 | :system-name "ftd") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/pkg-doc.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "pkg-doc" 'standard-mcclim-application 4 | :pretty-name "Pkg Doc" 5 | :icon nil 6 | :home-page "https://github.com/jschatzer/clim-pkg-doc" 7 | :git-repo "https://github.com/jschatzer/clim-pkg-doc.git" 8 | :system-name "clim-pkg-doc") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/clim-demo.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "clim-demo" 'standard-mcclim-application 4 | :pretty-name "Clim Demo" 5 | :icon nil 6 | :home-page "https://github.com/robert-strandh/McCLIM" 7 | :git-repo "https://github.com/robert-strandh/McCLIM.git" 8 | :system-name "clim-examples") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/editor.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "editor" 'standard-alias-application 4 | :pretty-name "Editor" 5 | :icon nil 6 | :menu-p nil 7 | :reference (find-application "climacs") 8 | ;;:reference (find-application "emacs") 9 | ) 10 | 11 | 12 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/listener.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "listener" 'standard-mcclim-application 4 | :pretty-name "Listener" 5 | :icon nil 6 | :home-page "https://github.com/robert-strandh/McCLIM" 7 | :git-repo "https://github.com/robert-strandh/McCLIM.git" 8 | :system-name "clim-listener") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/clim-debugger.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "clim-debugger" 'standard-mcclim-debugger-application 4 | :pretty-name "Clim Debugger" 5 | :icon nil 6 | :menu-p nil 7 | :requires-args-p t 8 | :home-page "" 9 | :git-repo "" 10 | :system-name "clim-debugger") 11 | -------------------------------------------------------------------------------- /Resource/src/views.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | 4 | (defgeneric desktop-presentation-type-of (object) 5 | (:method (object) 6 | (clim:presentation-type-of object))) 7 | 8 | ;; view 9 | 10 | (defclass extended-textual-view (clim:textual-view) 11 | ()) 12 | 13 | (defparameter +extended-textual-view+ 14 | (make-instance 'extended-textual-view)) 15 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (find-applications) 4 | 5 | (configure-application (find-application :listener)) 6 | (configure-application (find-application :climacs)) 7 | (use-application-as-external-debugger "swank-debugger") 8 | (use-application-as-debugger "swank-debugger") 9 | ;;(use-application-as-debugger "desktop-debugger") 10 | 11 | 12 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/system-browser-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app)) 6 | (if (null args) 7 | (trivial-open-browser:open-browser "https://common-lisp.net/project/mcclim/") 8 | (trivial-open-browser:open-browser (car args))))) 9 | 10 | 11 | -------------------------------------------------------------------------------- /Apps/debugger/README.org: -------------------------------------------------------------------------------- 1 | * Debugger (mcclim-desktop) 2 | 3 | An improved version of the standard clim debugger. This project started 4 | from the wanderful code of @gabriel-laddel ([[https://github.com/robert-strandh/McCLIM/issues/55][link]]). 5 | 6 | #+CAPTION: Screenshot 7 | #+NAME: fig:screenshot 8 | [[./doc/img/screenshot-01.jpg]] 9 | 10 | ** Usage 11 | 12 | ** Installation 13 | 14 | 15 | -------------------------------------------------------------------------------- /Sys/src/clipboard.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-sys) 2 | 3 | (defun copy-to-x11-clipboard (string) 4 | (with-input-from-string (input-stream 5 | (coerce string 'string)) 6 | (uiop:run-program "xclip -selection clipboard -i " 7 | :output nil :input input-stream))) 8 | 9 | (defun paste-from-x11-clipboard () 10 | (uiop:run-program "xclip -selection clipboard -o" :output :string)) 11 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/class-browser.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "class-browser" 'standard-mcclim-application 4 | :pretty-name "Class Browser" 5 | :icon nil 6 | :home-page "https://github.com/pocket7878/clim-class-browser" 7 | :git-repo "https://github.com/pocket7878/clim-class-browser.git" 8 | :system-name "clim-class-browser") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/scliba.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "scliba" 'standard-mcclim-application 4 | :pretty-name "Scliba" 5 | :icon nil 6 | :menu-p t 7 | :requires-args-p nil 8 | :home-page "https://github.com/admich/scliba" 9 | :git-repo "https://github.com/admich/scliba.git" 10 | :system-name "scliba-gui") 11 | -------------------------------------------------------------------------------- /Apps/launcher/README.org: -------------------------------------------------------------------------------- 1 | * Launcher (mcclim-desktop) 2 | 3 | #+CAPTION: Screenshot 4 | #+NAME: fig:screenshot 5 | [[./doc/img/screenshot-01.jpg]] 6 | 7 | 8 | ** Usage 9 | 10 | ** Installation 11 | 12 | ** Keystroke 13 | 14 | | Keystroke | Command | 15 | |-------------+--------------| 16 | | (#\q :meta) | quit | 17 | | (#\r :meta) | refresh | 18 | | (#\c :meta) | clear window | 19 | -------------------------------------------------------------------------------- /Sys/src/screenshot.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-sys) 2 | 3 | (defun take-x11-screenshot (pathname) 4 | (let ((id (string-trim '(#\Space #\Tab #\Newline) 5 | (uiop:run-program "xprop -root | grep '_NET_ACTIVE_WINDOW(WINDOW)' | awk -F ' ' '{print $5}' | tr ',' ' '" 6 | :output :string)))) 7 | (uiop:run-program (format nil "import -window ~A ~A" id 8 | (namestring pathname))))) 9 | 10 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/desktop-debugger-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app condition me-or-my-encapsulation) 5 | (declare (ignore app)) 6 | (funcall #'desktop-apps:debugger 7 | condition 8 | me-or-my-encapsulation))) 9 | 10 | (setf (application-debugger-fn *application*) 11 | #'desktop-apps:debugger) 12 | -------------------------------------------------------------------------------- /Apps/app-manager/README.org: -------------------------------------------------------------------------------- 1 | * App Manager (mcclim-desktop) 2 | 3 | #+CAPTION: Screenshot 4 | #+NAME: fig:screenshot 5 | [[./doc/img/screenshot-01.jpg]] 6 | 7 | 8 | ** Usage 9 | 10 | ** Installation 11 | 12 | ** Keystroke 13 | 14 | | Keystroke | Command | 15 | |-------------+--------------| 16 | | (#\q :meta) | quit | 17 | | (#\r :meta) | refresh | 18 | | (#\c :meta) | clear window | 19 | -------------------------------------------------------------------------------- /Apps/launcher/gui/utility.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-launcher) 2 | 3 | (defun edit-file (filename &key cb-fn) 4 | (let ((editor (find-application "editor"))) 5 | (launch-application editor :args (list filename) :cb-fn cb-fn))) 6 | 7 | #| 8 | (defun register-launcher-applications (&rest names) 9 | (dolist (name names) 10 | (when (find-application name) 11 | (push name *applications*)))) 12 | |# 13 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/console.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "console" 'standard-mcclim-application 4 | :pretty-name "Console" 5 | :icon nil 6 | :menu-p t 7 | :home-page "https://github.com/gas2serra/mcclim-desktop" 8 | :git-repo "https://github.com/gas2serra/mcclim-desktop.git" 9 | :system-name "mcclim-desktop-console") 10 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/launcher.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "launcher" 'standard-mcclim-application 4 | :pretty-name "Launcher" 5 | :icon nil 6 | :menu-p t 7 | :home-page "https://github.com/gas2serra/mcclim-desktop" 8 | :git-repo "https://github.com/gas2serra/mcclim-desktop.git" 9 | :system-name "mcclim-desktop-apps") 10 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/task-manager.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "task-manager" 'standard-mcclim-application 4 | :pretty-name "Task Manager" 5 | :icon nil 6 | :home-page "https://github.com/gas2serra/mcclim-desktop/tree/master/Apps/task-manager/" 7 | :git-repo "https://github.com/gas2serra/mcclim-desktop.git" 8 | :system-name "mcclim-desktop-apps") 9 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/clouseau.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "clouseau" 'standard-mcclim-application 4 | :pretty-name "Clouseau" 5 | :icon nil 6 | :menu-p nil 7 | :requires-args-p t 8 | :home-page "https://github.com/robert-strandh/McCLIM" 9 | :git-repo "https://github.com/robert-strandh/McCLIM.git" 10 | :system-name "clouseau") 11 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/app-manager.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "app-manager" 'standard-mcclim-application 4 | :pretty-name "App Manager" 5 | :icon nil 6 | :menu-p t 7 | :home-page "https://github.com/gas2serra/mcclim-desktop" 8 | :git-repo "https://github.com/gas2serra/mcclim-desktop.git" 9 | :system-name "mcclim-desktop-apps") 10 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/system-browser.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "system-browser" 'standard-cl-application 4 | :pretty-name "System Browser" 5 | :icon nil 6 | :menu-p nil 7 | :home-page "https://github.com/eudoxia0/trivial-open-browser" 8 | :git-repo "https://github.com/eudoxia0/trivial-open-browser.git" 9 | :system-name "trivial-open-browser") 10 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/apropos-navigator.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "apropos-navigator" 'standard-mcclim-application 4 | :pretty-name "Apropos Navigator" 5 | :icon nil 6 | :home-page "https://github.com/gas2serra/mcclim-desktop/tree/master/Apps/apropos/" 7 | :git-repo "https://github.com/gas2serra/mcclim-desktop.git" 8 | :system-name "mcclim-desktop-apps" 9 | :frame-class nil) 10 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/desktop-debugger.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (register-application "desktop-debugger" 'standard-mcclim-debugger-application 4 | :pretty-name "Desktop Debugger" 5 | :icon nil 6 | :menu-p nil 7 | :requires-args-p t 8 | :home-page "https://github.com/gas2serra/mcclim-desktop/tree/master/Apps/debugger/" 9 | :git-repo "https://github.com/gas2serra/mcclim-desktop.git" 10 | :system-name "mcclim-desktop-apps") 11 | -------------------------------------------------------------------------------- /Core/src/init.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | (defun initialize () 4 | (ensure-all-user-directories-exist) 5 | (find-system-directories) 6 | (let ((init-file (find-file *init-file-name*))) 7 | (if init-file 8 | (load init-file) 9 | (log-warn (format nil "Init file (~A) not found" 10 | *init-file-name*))))) 11 | 12 | (defun configure () 13 | (let ((config-file (find-file *config-file-name*))) 14 | (if config-file 15 | (load config-file) 16 | (log-warn (format nil "Config file (~A) not found" 17 | *config-file-name*))))) 18 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/clim-debugger-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (load-application (find-application :clouseau)) 4 | (load (merge-pathnames "Apps/Debugger/clim-debugger.lisp" 5 | (asdf:component-pathname (asdf:find-system "mcclim")))) 6 | 7 | (setf (application-entry-fn *application*) 8 | #'(lambda (app condition me-or-my-encapsulation) 9 | (declare (ignore app)) 10 | (funcall #'clim-debugger:debugger 11 | condition me-or-my-encapsulation))) 12 | 13 | (setf (application-debugger-fn *application*) 14 | #'clim-debugger:debugger) 15 | -------------------------------------------------------------------------------- /Apps/packages.lisp: -------------------------------------------------------------------------------- 1 | (defpackage :desktop-apps 2 | (:use :common-lisp) 3 | (:import-from desktop-launcher 4 | #:run-launcher) 5 | (:import-from desktop-task-manager 6 | #:run-task-manager) 7 | (:import-from desktop-app-manager 8 | #:run-app-manager) 9 | (:import-from desktop-apropos 10 | #:run-apropos-navigator) 11 | (:import-from desktop-debugger 12 | #:debugger) 13 | (:import-from desktop-console 14 | #:run-console) 15 | (:export 16 | #:run-launcher 17 | #:run-task-manager 18 | #:run-app-manager 19 | #:run-apropos-navigator 20 | #:run-console 21 | #:debugger)) 22 | 23 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/apps/_%sample_.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | ;;; 4 | ;;; Examples 5 | ;;; 6 | #| 7 | 8 | (register-application "" 'standard-mcclim-application 9 | :pretty-name "" 10 | :icon nil 11 | :home-page nil 12 | :git-repo nil 13 | :system-name "") 14 | 15 | (register-application "" 'standard-shell-application 16 | :pretty-name "" 17 | :make-command-fn #'(lambda (&rest args) 18 | )) 19 | 20 | (register-application "" 'standard-alias-application 21 | :pretty-name "" 22 | :icon nil 23 | :reference (find-application "") 24 | ) 25 | 26 | |# 27 | 28 | 29 | -------------------------------------------------------------------------------- /Sys/mcclim-desktop-sys.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of mcclim-desktop project. 3 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 4 | |# 5 | 6 | #| 7 | Author: Alessandro Serra (gas2serra@gmail.com) 8 | |# 9 | 10 | (in-package :cl-user) 11 | (defpackage #:mcclim-desktop-asd 12 | (:use :cl :asdf)) 13 | (in-package #:mcclim-desktop-asd) 14 | 15 | (defsystem mcclim-desktop-sys 16 | :version "0.2" 17 | :author "Alessandro Serra" 18 | :license "GPLv3" 19 | :depends-on (:asdf :drei-mcclim) 20 | :components ((:module "src" 21 | :serial t 22 | :components 23 | ((:file "clipboard") 24 | (:file "screenshot") 25 | (:file "kill-ring")))) 26 | :description "McCLIM Desktop") 27 | -------------------------------------------------------------------------------- /Apps/task-manager/README.org: -------------------------------------------------------------------------------- 1 | * Task Manager (mcclim-desktop) 2 | 3 | #+CAPTION: Screenshot 4 | #+NAME: fig:screenshot 5 | [[./doc/img/screenshot-01.jpg]] 6 | 7 | ** Usage 8 | 9 | *** CL 10 | 11 | #+BEGIN_SRC lisp 12 | 13 | (desktop:run-task-manager) 14 | 15 | #+END_SRC 16 | 17 | *** listener 18 | 19 | #+BEGIN_SRC 20 | 21 | ,Run Task Manager 22 | 23 | #+END_SRC 24 | 25 | 26 | ** Tested 27 | 28 | *** Backends 29 | - CLX 30 | - CLXv3 31 | 32 | *** CL 33 | - sbcl 16.1.2 34 | - ccl 1.11 35 | 36 | 37 | ** Author 38 | 39 | + Alessandro Serra (gas2serra@gmail.com) 40 | 41 | ** Copyright 42 | 43 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 44 | 45 | ** License 46 | 47 | Licensed under the GPLv3 License. 48 | -------------------------------------------------------------------------------- /Resource/mcclim-desktop-resource.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of mcclim-desktop project. 3 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 4 | |# 5 | 6 | #| 7 | Author: Alessandro Serra (gas2serra@gmail.com) 8 | |# 9 | 10 | (in-package :cl-user) 11 | (defpackage #:mcclim-desktop-asd 12 | (:use :cl :asdf)) 13 | (in-package #:mcclim-desktop-asd) 14 | 15 | (defsystem mcclim-desktop-resource 16 | :version "0.2" 17 | :author "Alessandro Serra" 18 | :license "GPLv3" 19 | :depends-on (:mcclim-desktop-core) 20 | :components ((:module "src" 21 | :serial t 22 | :components 23 | ((:file "views") 24 | (:file "application") 25 | (:file "frame") 26 | (:file "thread") 27 | (:file "debugger")))) 28 | :description "McCLIM Desktop") 29 | -------------------------------------------------------------------------------- /Apps/debugger/mcclim-desktop-debugger.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of mcclim-desktop project. 3 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 4 | |# 5 | 6 | #| 7 | Debugger 8 | 9 | Author: Alessandro Serra (gas2serra@gmail.com) 10 | |# 11 | 12 | (in-package :cl-user) 13 | (defpackage #:mcclim-desktop-debugger-asd 14 | (:use :cl :asdf)) 15 | (in-package #:mcclim-desktop-debugger-asd) 16 | 17 | (defsystem #:mcclim-desktop-debugger 18 | :version "0.1" 19 | :author "Alessandro Serra" 20 | :license "GPLv3" 21 | :depends-on (:mcclim :clim-listener :anaphora :clouseau) 22 | :components ((:module "src" 23 | :serial t 24 | :components 25 | ((:file "mcclim-desktop-debugger") 26 | (:file "debugger")))) 27 | :description "Debugger") 28 | 29 | 30 | -------------------------------------------------------------------------------- /mcclim-desktop.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of mcclim-desktop project. 3 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 4 | |# 5 | 6 | #| 7 | Author: Alessandro Serra (gas2serra@gmail.com) 8 | |# 9 | 10 | (in-package :cl-user) 11 | (defpackage #:mcclim-desktop-asd 12 | (:use :cl :asdf)) 13 | (in-package #:mcclim-desktop-asd) 14 | 15 | (defsystem mcclim-desktop/internals 16 | :components ((:file "packages"))) 17 | 18 | (defsystem mcclim-desktop 19 | :version "0.2" 20 | :author "Alessandro Serra" 21 | :license "GPLv3" 22 | :depends-on (:mcclim 23 | :mcclim-desktop/internals 24 | :mcclim-desktop-sys 25 | :mcclim-desktop-core 26 | :mcclim-desktop-resource) 27 | :components ((:file "init")) 28 | :description "McCLIM Desktop") 29 | 30 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/swank-debugger-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (defun desktop-swank-debugger-hook (condition me-or-my-encapsulation) 4 | (unless swank::*connections* 5 | (launch-app :swank-server) 6 | (sleep 3.0) 7 | (launch-app :slime) 8 | (sleep 5.0)) 9 | (funcall #'swank:swank-debugger-hook condition me-or-my-encapsulation)) 10 | 11 | (setf (application-entry-fn *application*) 12 | #'(lambda (app condition me-or-my-encapsulation) 13 | (declare (ignore app)) 14 | (funcall #'desktop-swank-debugger-hook 15 | condition me-or-my-encapsulation))) 16 | 17 | (setf (application-debugger-fn *application*) 18 | (lambda (condition me-or-my-encapsulation) 19 | (funcall #'desktop-swank-debugger-hook 20 | condition me-or-my-encapsulation))) 21 | 22 | 23 | -------------------------------------------------------------------------------- /Apps/mcclim-desktop-apps.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of mcclim-desktop project. 3 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 4 | |# 5 | 6 | #| 7 | Author: Alessandro Serra (gas2serra@gmail.com) 8 | |# 9 | 10 | (in-package :cl-user) 11 | (defpackage #:mcclim-desktop-asd 12 | (:use :cl :asdf)) 13 | (in-package #:mcclim-desktop-asd) 14 | 15 | (defsystem mcclim-desktop-apps 16 | :version "0.1" 17 | :author "Alessandro Serra" 18 | :license "GPLv3" 19 | :depends-on (:mcclim-desktop 20 | :mcclim-desktop-launcher 21 | :mcclim-desktop-app-manager 22 | :mcclim-desktop-task-manager 23 | :mcclim-desktop-apropos 24 | :mcclim-desktop-debugger 25 | :mcclim-desktop-console 26 | ) 27 | :components ((:file "packages")) 28 | :description "McCLIM Desktop Apps") 29 | -------------------------------------------------------------------------------- /Core/src/application-discovery.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | ;;;; 4 | ;;;; Application discovery 5 | ;;;; 6 | 7 | (defun discover-application (name &optional force-p) 8 | (let ((application (find-registered-application name nil))) 9 | (when (or force-p (null application)) 10 | (let ((application-file 11 | (find-application-file name))) 12 | (when application-file 13 | (load application-file))))) 14 | (find-registered-application name)) 15 | 16 | (defun discover-applications (&optional force-p) 17 | (dolist (file (find-application-files)) 18 | (discover-application (pathname-name file) force-p))) 19 | 20 | (defun refresh-application (name) 21 | (discover-application name t)) 22 | 23 | (defun refresh-applications () 24 | (remove-registered-applications) 25 | (discover-applications t)) 26 | -------------------------------------------------------------------------------- /Apps/app-manager/mcclim-desktop-app-manager.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of mcclim-desktop project. 3 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 4 | |# 5 | 6 | #| 7 | Author: Alessandro Serra (gas2serra@gmail.com) 8 | |# 9 | 10 | (in-package :cl-user) 11 | (defpackage #:mcclim-desktop-asd 12 | (:use :cl :asdf)) 13 | (in-package #:mcclim-desktop-asd) 14 | 15 | (defsystem mcclim-desktop-app-manager 16 | :version "0.1" 17 | :author "Alessandro Serra" 18 | :license "GPLv3" 19 | :depends-on (:mcclim :mcclim-desktop) 20 | :components ((:file "packages") 21 | (:module "gui" 22 | :serial t 23 | :depends-on ("packages") 24 | :components 25 | ((:file "presentations") 26 | (:file "frame") 27 | (:file "commands") 28 | (:file "main")))) 29 | :description "McCLIM Desktop App Manager") 30 | -------------------------------------------------------------------------------- /Apps/task-manager/gui/main.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-task-manager) 2 | 3 | (defun run-task-manager (&key (new-process nil) 4 | (width 790) 5 | (height 650) 6 | port 7 | frame-manager 8 | (pretty-name "Task Manager") 9 | (process-name "task-manager")) 10 | (let* ((fm (or frame-manager (clim:find-frame-manager :port (or port (clim:find-port))))) 11 | (frame (clim:make-application-frame 'task-manager 12 | :pretty-name pretty-name 13 | :frame-manager fm 14 | :width width 15 | :height height))) 16 | (flet ((run () 17 | (unwind-protect (clim:run-frame-top-level frame) 18 | (clim:disown-frame fm frame)))) 19 | (if new-process 20 | (values (clim-sys:make-process #'run :name process-name) 21 | frame) 22 | (run))))) 23 | -------------------------------------------------------------------------------- /Apps/console/gui/main.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-console) 2 | 3 | (defun run-console (&key (new-process nil) 4 | (width nil) 5 | (height nil) 6 | port 7 | frame-manager 8 | (pretty-name "Desktop Console") 9 | (process-name "desktop-console")) 10 | (let* ((fm (or frame-manager (clim:find-frame-manager :port (or port (clim:find-port))))) 11 | (frame (clim:make-application-frame 'desktop-console 12 | :pretty-name pretty-name 13 | :frame-manager fm 14 | :width width 15 | :height height))) 16 | (flet ((run () 17 | (unwind-protect (clim:run-frame-top-level frame) 18 | (clim:disown-frame fm frame)))) 19 | (if new-process 20 | (values (clim-sys:make-process #'run :name process-name) 21 | frame) 22 | (run))))) 23 | -------------------------------------------------------------------------------- /Apps/console/mcclim-desktop-console.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of mcclim-desktop project. 3 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 4 | |# 5 | 6 | #| 7 | Author: Alessandro Serra (gas2serra@gmail.com) 8 | |# 9 | 10 | (in-package :cl-user) 11 | (defpackage #:mcclim-desktop-asd 12 | (:use :cl :asdf)) 13 | (in-package #:mcclim-desktop-asd) 14 | 15 | (defsystem mcclim-desktop-console 16 | :version "0.1" 17 | :author "Alessandro Serra" 18 | :license "GPLv3" 19 | :depends-on (:mcclim :mcclim-desktop :osicat) 20 | :components ((:file "packages") 21 | (:module "gui" 22 | :serial t 23 | :depends-on ("packages") 24 | :components 25 | ( 26 | 27 | 28 | (:file "wholine") 29 | (:file "frame") 30 | (:file "commands") 31 | (:file "main")))) 32 | :description "McCLIM Desktop Console") 33 | -------------------------------------------------------------------------------- /Apps/task-manager/mcclim-desktop-task-manager.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of mcclim-panter project. 3 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 4 | |# 5 | 6 | #| 7 | Task Manager 8 | 9 | Author: Alessandro Serra (gas2serra@gmail.com) 10 | |# 11 | 12 | (in-package :cl-user) 13 | (defpackage #:mcclim-desktop-task-manager-asd 14 | (:use :cl :asdf)) 15 | (in-package #:mcclim-desktop-task-manager-asd) 16 | 17 | (defsystem #:mcclim-desktop-task-manager 18 | :version "0.1" 19 | :author "Alessandro Serra" 20 | :license "GPLv3" 21 | :depends-on (:mcclim :anaphora :clouseau :trivial-timers) 22 | :components ((:file "mcclim-desktop-task-manager") 23 | (:module "gui" 24 | :serial t 25 | :components 26 | ((:file "frame") 27 | (:file "commands") 28 | (:file "main")))) 29 | :description "Task Manager") 30 | -------------------------------------------------------------------------------- /Apps/launcher/gui/main.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-launcher) 2 | 3 | (defun run-launcher (&key (new-process nil) 4 | (width nil) 5 | (height nil) 6 | port 7 | frame-manager 8 | (pretty-name "Desktop Launcher") 9 | (process-name "desktop-launcher")) 10 | (let* ((fm (or frame-manager (clim:find-frame-manager :port (or port (clim:find-port))))) 11 | (frame (clim:make-application-frame 'desktop-launcher 12 | :pretty-name pretty-name 13 | :frame-manager fm 14 | :width width 15 | :height height))) 16 | (flet ((run () 17 | (unwind-protect (clim:run-frame-top-level frame) 18 | (clim:disown-frame fm frame)))) 19 | (if new-process 20 | (values (clim-sys:make-process #'run :name process-name) 21 | frame) 22 | (run))))) 23 | -------------------------------------------------------------------------------- /Apps/app-manager/gui/main.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-app-manager) 2 | 3 | (defun run-app-manager (&key (new-process nil) 4 | (width nil) 5 | (height nil) 6 | port 7 | frame-manager 8 | (pretty-name "Desktop App-Manager") 9 | (process-name "desktop-app-manager")) 10 | (let* ((fm (or frame-manager (clim:find-frame-manager :port (or port (clim:find-port))))) 11 | (frame (clim:make-application-frame 'desktop-app-manager 12 | :pretty-name pretty-name 13 | :frame-manager fm 14 | :width width 15 | :height height))) 16 | (flet ((run () 17 | (unwind-protect (clim:run-frame-top-level frame) 18 | (clim:disown-frame fm frame)))) 19 | (if new-process 20 | (values (clim-sys:make-process #'run :name process-name) 21 | frame) 22 | (run))))) 23 | -------------------------------------------------------------------------------- /Apps/launcher/mcclim-desktop-launcher.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of mcclim-desktop project. 3 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 4 | |# 5 | 6 | #| 7 | Author: Alessandro Serra (gas2serra@gmail.com) 8 | |# 9 | 10 | (in-package :cl-user) 11 | (defpackage #:mcclim-desktop-asd 12 | (:use :cl :asdf)) 13 | (in-package #:mcclim-desktop-asd) 14 | 15 | (defsystem mcclim-desktop-launcher 16 | :version "0.1" 17 | :author "Alessandro Serra" 18 | :license "GPLv3" 19 | :depends-on (:mcclim :mcclim-desktop) 20 | :components ((:file "packages") 21 | (:module "gui" 22 | :serial t 23 | :depends-on ("packages") 24 | :components 25 | ((:file "parameters") 26 | (:file "utility") 27 | (:file "presentations") 28 | (:file "frame") 29 | (:file "commands") 30 | (:file "main")))) 31 | :description "McCLIM Desktop Launcher") 32 | -------------------------------------------------------------------------------- /Core/mcclim-desktop-core.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of mcclim-desktop project. 3 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 4 | |# 5 | 6 | #| 7 | Author: Alessandro Serra (gas2serra@gmail.com) 8 | |# 9 | 10 | (in-package :cl-user) 11 | (defpackage #:mcclim-desktop-asd 12 | (:use :cl :asdf)) 13 | (in-package #:mcclim-desktop-asd) 14 | 15 | (defsystem mcclim-desktop-core 16 | :version "0.2" 17 | :author "Alessandro Serra" 18 | :license "GPLv3" 19 | :depends-on (:bordeaux-threads :alexandria :swank) 20 | :components ((:module "src" 21 | :serial t 22 | :components 23 | ((:file "debugger") 24 | (:file "logger") 25 | (:file "standard-pathnames") 26 | (:file "application") 27 | (:file "applications") 28 | (:file "application-discovery") 29 | (:file "application-mixins") 30 | (:file "standard-application") 31 | (:file "api") 32 | (:file "init")))) 33 | :description "McCLIM Desktop") 34 | 35 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/listener-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app args)) 6 | (clim-listener:run-listener))) 7 | 8 | 9 | 10 | ;;; 11 | ;;; run panter applications 12 | ;;; 13 | 14 | (clim-listener::define-listener-command (com-run-apropos-navigator :name t) 15 | nil 16 | (run-app "apropos-navigator")) 17 | 18 | (clim-listener::define-listener-command (com-run-task-manager :name t) 19 | nil 20 | (run-app "task-manager")) 21 | 22 | ;;; 23 | ;;; debugger 24 | ;;; 25 | 26 | (clim-listener::define-listener-command (com-enable-desktop-debugger :name t) () 27 | (format t "Enabled desktop debugger~%") 28 | (use-application-as-debugger "desktop-debugger")) 29 | 30 | (clim-listener::define-listener-command (com-enable-swank-debugger :name t) () 31 | (format t "Enabled swank debugger~%") 32 | (use-application-as-debugger "swank-debugger")) 33 | -------------------------------------------------------------------------------- /Apps/apropos/README.org: -------------------------------------------------------------------------------- 1 | * Apropos Navigator (mcclim-desktop) 2 | 3 | An interactive apropos application. 4 | This project started from the wanderful code of @gabriel-laddel ([[https://github.com/robert-strandh/McCLIM/wiki/Navigator][link]]). 5 | 6 | 7 | #+CAPTION: Screenshot 8 | #+NAME: fig:screenshot 9 | [[./doc/img/screenshot-01.jpg]] 10 | 11 | ** Usage 12 | 13 | *** CL 14 | 15 | #+BEGIN_SRC lisp 16 | (panter:run-apropos-navigator) 17 | #+END_SRC 18 | 19 | *** listener 20 | 21 | #+BEGIN_SRC 22 | ,Run Apropos Navigator 23 | #+END_SRC 24 | 25 | *** Drei/Climacs (lisp files) 26 | 27 | #+BEGIN_SRC lisp 28 | (#\s :meta :control) 29 | #+END_SRC 30 | 31 | ** Tested 32 | 33 | *** Backends 34 | - CLX 35 | - CLXv3 36 | 37 | *** CL 38 | - sbcl 16.1.2 39 | - ccl 1.11 40 | 41 | 42 | ** Author 43 | 44 | + Alessandro Serra (gas2serra@gmail.com) 45 | 46 | ** Copyright 47 | 48 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 49 | 50 | ** License 51 | 52 | Licensed under the GPLv3 License. 53 | -------------------------------------------------------------------------------- /Apps/apropos/mcclim-desktop-apropos.lisp: -------------------------------------------------------------------------------- 1 | (in-package :cl-user) 2 | 3 | (defpackage desktop-apropos 4 | (:use :cl :desktop :desktop-extensions) 5 | (:import-from :clim 6 | ) 7 | (:export 8 | ;; utility functions 9 | #:symbol-external-p 10 | #:symbol-bound-to 11 | #:list-symbol-bounding-types 12 | #:symbol-documentation 13 | #:symbol-description 14 | ;; iapropos 15 | #:*default-iapropos-max-result-length* 16 | #:*symbol-bounding-types* 17 | #:iapropos 18 | #:iapropos-text 19 | #:iapropos-package-text 20 | #:iapropos-external-yes/no 21 | #:iapropos-documentation-yes/no 22 | #:iapropos-bound-to 23 | #:iapropos-subclass-of 24 | #:iapropos-metaclass-of 25 | #:iapropos-filter-fn 26 | #:iapropos-max-result-length 27 | #:iapropos-result-overflow-p 28 | #:iapropos-syntax-error-p 29 | #:iapropos-matching-packages 30 | #:iapropos-matching-symbols 31 | #:iapropos-matching-symbol-p 32 | ;; gui 33 | #:run-apropos-navigator 34 | )) 35 | 36 | (in-package :desktop-apropos) 37 | -------------------------------------------------------------------------------- /Apps/app-manager/gui/commands.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-app-manager) 2 | 3 | 4 | (define-desktop-app-manager-command (com-quit :menu nil 5 | :keystroke (#\q :meta)) 6 | () 7 | (clim:frame-exit clim:*application-frame*)) 8 | 9 | 10 | (define-desktop-app-manager-command (com-refresh :menu nil 11 | :keystroke (#\r :meta)) 12 | () 13 | (clim:redisplay-frame-pane clim:*application-frame* 14 | (clim:find-pane-named clim:*application-frame* 'application-display))) 15 | 16 | (define-desktop-app-manager-command (com-refresh-apps :menu nil) 17 | () 18 | (refresh-applications) 19 | (clim:redisplay-frame-pane clim:*application-frame* 20 | (clim:find-pane-named clim:*application-frame* 'application-display))) 21 | 22 | (define-desktop-app-manager-command (com-clear-interactor 23 | :menu nil 24 | :keystroke (#\c :meta)) 25 | () 26 | (let ((pane (clim:find-pane-named clim:*application-frame* 'interactor))) 27 | (clim:window-clear pane))) 28 | 29 | 30 | 31 | 32 | ;; traslators 33 | 34 | -------------------------------------------------------------------------------- /Core/src/debugger.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | ;;;; 4 | ;;;; Debugging 5 | ;;;; 6 | 7 | (defvar *debugger* nil 8 | "The current debugger") 9 | 10 | (defvar *external-debugger* nil 11 | "The current external debugger") 12 | 13 | ;;; 14 | ;;; debugger hook 15 | ;;; 16 | 17 | (defun debugger-hook (condition me-or-my-encapsulation) 18 | (swank/backend:call-with-debugger-hook 19 | *external-debugger* 20 | (lambda () 21 | (if (or (eq (climi::port-event-process (climi::find-port)) 22 | (climi::current-process)) 23 | (null *debugger*)) 24 | (funcall *external-debugger* condition me-or-my-encapsulation) 25 | (funcall *debugger* condition me-or-my-encapsulation))))) 26 | 27 | ;;; functions 28 | 29 | (defun install-debugger-globally () 30 | (swank/backend:install-debugger-globally #'debugger-hook)) 31 | 32 | (defun use-debugger (debugger) 33 | (log-info (format nil "Use debugger: ~A~%" debugger)) 34 | (setq *debugger* debugger)) 35 | 36 | (defun use-external-debugger (debugger) 37 | (log-info (format nil "Use external debugger: ~A~%" debugger)) 38 | (setq *external-debugger* debugger)) 39 | -------------------------------------------------------------------------------- /Apps/apropos/mcclim-desktop-apropos.asd: -------------------------------------------------------------------------------- 1 | #| 2 | This file is a part of mcclim-panter project. 3 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 4 | |# 5 | 6 | #| 7 | Apropos Navigator 8 | 9 | Author: Alessandro Serra (gas2serra@gmail.com) 10 | |# 11 | 12 | (in-package :cl-user) 13 | (defpackage #:mcclim-desktop-apropos-asd 14 | (:use :cl :asdf)) 15 | (in-package #:mcclim-desktop-apropos-asd) 16 | 17 | (defsystem #:mcclim-desktop-apropos 18 | :version "0.1" 19 | :author "Alessandro Serra" 20 | :license "GPLv3" 21 | :depends-on (:mcclim :climacs :clim-listener :cl-ppcre :anaphora :swank :closer-mop :clouseau) 22 | :components ((:file "mcclim-desktop-apropos") 23 | (:module "src" 24 | :serial t 25 | :depends-on ("mcclim-desktop-apropos") 26 | :components 27 | ((:file "utility") 28 | (:file "iapropos") 29 | (:file "iapropos-preselects") 30 | (:file "presentations"))) 31 | (:module "gui" 32 | :serial t 33 | :depends-on ("src") 34 | :components 35 | ((:file "parameters") 36 | (:file "frame") 37 | (:file "commands") 38 | (:file "main")))) 39 | :description "Apropos Navigator") 40 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/beirc-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (when *application* 4 | (setf (application-entry-fn *application*) 5 | #'(lambda (app &rest args) 6 | (declare (ignore app args)) 7 | (beirc:beirc :new-process nil)))) 8 | 9 | (defmethod irc::nickname ((u (eql nil))) 10 | nil) 11 | 12 | (when *application* 13 | (setf beirc:*beirc-user-init-file* (application-style-file *application*)) 14 | (setf beirc:*default-fill-column* 110) 15 | ;;(setf beirc:*default-sound-player* nil) 16 | (setf beirc:*default-nick* (format nil "mcclim-desktop")) 17 | (setf beirc::*default-realname* (format nil "Alessandro")) 18 | (setf beirc:*default-web-browser "/usr/bin/firefox") 19 | (setf beirc::*auto-connect-list* '("irc.freenode.net")) 20 | (setf beirc::*auto-identify-list* '("irc.freenode.net")) 21 | (setf beirc::*nickserv-password-alist* '(("irc.freenode.net" . "password"))) 22 | (setf beirc:*auto-join-alist* '(("irc.freeenode.net" . ("#maxima" "#lisp" "#clnoobs" "#sbcl" "#lispgames" "#scheme" "#emacs" "#algorithms" "##cs" "##programming" "##math" "##asm" "##linux" "##kernel" "##slackware" "#freenode"))))) 23 | 24 | 25 | -------------------------------------------------------------------------------- /Apps/apropos/gui/parameters.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-apropos) 2 | 3 | ;;; 4 | ;;; navigator parameters 5 | ;;; 6 | 7 | (defparameter *apropos-navigator-heading-text-style* (clim:make-text-style 8 | nil 9 | :bold 13)) 10 | 11 | (defparameter *apropos-navigator-sub-heading-text-style* (clim:make-text-style 12 | nil 13 | :bold 11)) 14 | 15 | (defparameter *apropos-navigator-subclas-of-options* 16 | (list (cons "nil" nil) 17 | (cons "sheet" 'clim:sheet) 18 | (cons "pane" 'clim:pane) 19 | (cons "gadget" 'clim:gadget) 20 | (cons "presentation" 'clim:presentation) 21 | (cons "command-table" 'clim:command-table) 22 | (cons "application-frame" 'clim:application-frame))) 23 | 24 | (defparameter *apropos-navigator-metaclas-of-options* 25 | (list 26 | (cons "nil" nil))) 27 | 28 | (defparameter *apropos-navigator-preselect-options* 29 | (list (cons "nil" nil) 30 | (cons "command" 31 | #'command-internal-preselect) 32 | (cons "command-table" 33 | #'command-table-preselect) 34 | (cons "presentation-type" 35 | #'presentation-type-preselect) 36 | (cons "view-type" 37 | #'view-type-preselect))) 38 | 39 | 40 | 41 | 42 | -------------------------------------------------------------------------------- /Core/src/standard-application.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | ;;;; 4 | ;;;; Standard Application 5 | ;;;; 6 | 7 | (defclass standard-cl-application (standard-cl-application-mixin 8 | simple-cl-application-mixin 9 | cl-application) 10 | ()) 11 | 12 | (defclass standard-mcclim-application (standard-cl-application-mixin 13 | simple-cl-application-mixin 14 | mcclim-application) 15 | ()) 16 | 17 | (defclass standard-alias-application (standard-application-mixin 18 | alias-application) 19 | ()) 20 | 21 | (defclass standard-link-application (standard-application-mixin 22 | link-application) 23 | ()) 24 | 25 | (defclass standard-shell-application (standard-application-mixin 26 | simple-shell-application-mixin 27 | shell-application) 28 | ()) 29 | 30 | (defclass standard-debugger-application (standard-cl-application-mixin 31 | simple-cl-application-mixin 32 | simple-debugger-application-mixin 33 | cl-application) 34 | ()) 35 | 36 | (defclass standard-mcclim-debugger-application (standard-cl-application-mixin 37 | simple-cl-application-mixin 38 | simple-debugger-application-mixin 39 | mcclim-application) 40 | ()) 41 | 42 | -------------------------------------------------------------------------------- /Apps/apropos/gui/main.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-apropos) 2 | 3 | ;;; 4 | ;;; run 5 | ;;; 6 | 7 | #| 8 | (defun run-apropos-navigator () 9 | (let ((*return-values* nil)) 10 | (let* ((frame (clim:make-application-frame 'apropos-navigator))) 11 | (setf (clim:frame-current-layout frame) :default) 12 | (clim:run-frame-top-level frame :name "apropos-navigator")) 13 | *return-values*)) 14 | |# 15 | 16 | (defun run-apropos-navigator (&key (new-process nil) 17 | (width 790) 18 | (height 550) 19 | port 20 | frame-manager 21 | (pretty-name "Apropos Navigator") 22 | (process-name "apropos-navigator")) 23 | (let* ((fm (or frame-manager (clim:find-frame-manager :port (or port (clim:find-port))))) 24 | (frame (clim:make-application-frame 'apropos-navigator 25 | :pretty-name pretty-name 26 | :frame-manager fm 27 | :width width 28 | :height height))) 29 | (flet ((run () 30 | (let ((*return-values* nil)) 31 | (unwind-protect (clim:run-frame-top-level frame) 32 | (clim:disown-frame fm frame)) 33 | *return-values*))) 34 | (if new-process 35 | (values (clim-sys:make-process #'run :name process-name) 36 | frame) 37 | (run))))) 38 | -------------------------------------------------------------------------------- /Core/src/applications.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | ;;;; 4 | ;;;; Applications 5 | ;;;; 6 | 7 | (defvar *registered-applications* (make-hash-table :test #'equal) 8 | "The registered applications") 9 | 10 | ;;; 11 | ;;; functions 12 | ;;; 13 | 14 | (defun register-new-application (application) 15 | (setf (gethash (application-name application) *registered-applications*) 16 | application) 17 | (log-info (format nil "Registered ~A application" (application-name application)))) 18 | 19 | (defun remove-registered-application (application) 20 | (setf (gethash (application-name application) *registered-applications*) nil)) 21 | 22 | (defun remove-registered-applications () 23 | (setf *registered-applications* (make-hash-table :test #'equal))) 24 | 25 | (defun find-registered-application (application-designator &optional (errorp t)) 26 | (typecase application-designator 27 | (string 28 | (or (gethash application-designator *registered-applications*) 29 | (and errorp (error "Application ~A not found" application-designator)))) 30 | (symbol 31 | (find-application (string-downcase (string application-designator)) errorp)) 32 | (application 33 | application-designator))) 34 | 35 | (defun registered-applications () 36 | (alexandria:hash-table-values *registered-applications*)) 37 | 38 | (defun map-registered-applications (fn) 39 | (alexandria:maphash-values fn *registered-applications*)) 40 | -------------------------------------------------------------------------------- /Apps/apropos/src/iapropos-preselects.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-apropos) 2 | 3 | ;;; 4 | ;;; Preselect 5 | ;;; 6 | 7 | (defun command-internal-preselect (iapropos) 8 | (let ((scanner (cl-ppcre:create-scanner "^COM-" :case-insensitive-mode t))) 9 | (flet ((filter-fn (symbol) 10 | (let* ((name (symbol-name symbol))) 11 | (and (cl-ppcre::scan scanner name) 12 | (cl-ppcre::scan #\% name))))) 13 | (setf (iapropos-filter-fn iapropos) #'filter-fn) 14 | (setf (iapropos-subclass-of iapropos) nil) 15 | (setf (iapropos-metaclass-of iapropos) nil) 16 | (setf (iapropos-bound-to iapropos) :function)))) 17 | 18 | (defun command-table-preselect (iapropos) 19 | (flet ((filter-fn (symbol) 20 | (clim:find-command-table symbol :errorp nil))) 21 | (setf (iapropos-filter-fn iapropos) #'filter-fn) 22 | (setf (iapropos-subclass-of iapropos) nil) 23 | (setf (iapropos-metaclass-of iapropos) nil) 24 | (setf (iapropos-bound-to iapropos) nil))) 25 | 26 | (defun presentation-type-preselect (iapropos) 27 | (setf (iapropos-filter-fn iapropos) nil) 28 | (setf (iapropos-subclass-of iapropos) nil) 29 | (setf (iapropos-metaclass-of iapropos) 'climi::presentation-type-class) 30 | (setf (iapropos-bound-to iapropos) :class)) 31 | 32 | (defun view-type-preselect (iapropos) 33 | (setf (iapropos-filter-fn iapropos) nil) 34 | (setf (iapropos-subclass-of iapropos) 'clim:view) 35 | (setf (iapropos-metaclass-of iapropos) nil) 36 | (setf (iapropos-bound-to iapropos) :class)) 37 | -------------------------------------------------------------------------------- /Apps/apropos/src/presentations.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-apropos) 2 | 3 | 4 | ;;; 5 | ;;; symbol 6 | ;;; 7 | 8 | (defclass fully-qualified-symbol-view (clim:textual-view) 9 | ()) 10 | 11 | (defparameter +fully-qualified-symbol-view+ 12 | (make-instance 'fully-qualified-symbol-view)) 13 | 14 | (clim:define-presentation-method clim:present (object (type symbol) stream 15 | (view fully-qualified-symbol-view) 16 | &key acceptably for-context-type) 17 | (declare (ignore acceptably for-context-type)) 18 | (let ((*package* (find-package :common-lisp-user))) 19 | (prin1 object stream))) 20 | 21 | ;;; 22 | ;;; package 23 | ;;; 24 | 25 | 26 | ;;(clim:define-presentation-type package ()) 27 | 28 | (clim:define-presentation-method clim:present (object (type package) stream 29 | (view clim:textual-view) 30 | &key acceptably for-context-type) 31 | (declare (ignore acceptably for-context-type)) 32 | (princ (package-name object) stream)) 33 | 34 | ;;; 35 | ;;; object 36 | ;;; 37 | 38 | (clim:define-presentation-type object ()) 39 | 40 | (clim:define-presentation-method clim:present (object (type object) stream 41 | (view clim:textual-view) 42 | &key acceptably for-context-type) 43 | (declare (ignore acceptably for-context-type)) 44 | (princ object stream)) 45 | 46 | ;;; 47 | ;;; location 48 | ;;; 49 | 50 | (clim:define-presentation-type source-location ()) 51 | 52 | (clim:define-presentation-method clim:present (loc (type source-location) stream 53 | (view clim:textual-view) 54 | &key acceptably for-context-type) 55 | (declare (ignore acceptably for-context-type)) 56 | (princ (format nil "~A:~A" (car loc) (cdr loc)) stream)) 57 | -------------------------------------------------------------------------------- /Apps/task-manager/gui/commands.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-task-manager) 2 | 3 | ;;; 4 | ;;; task manager commands 5 | ;;; 6 | 7 | (defun mem-usage () 8 | #+(or cmu scl) (lisp::dynamic-usage) 9 | #+sbcl (sb-kernel:dynamic-usage) 10 | #+lispworks (getf (system:room-values) :total-allocated) 11 | #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes)) 12 | #+clisp (values (sys::%room)) 13 | #-(or cmu scl sbcl lispworks openmcl clisp) 0) 14 | 15 | 16 | (define-task-manager-command (com-quit :name "Quit" 17 | :keystroke (#\q :meta)) 18 | () 19 | (clim:frame-exit clim:*application-frame*)) 20 | 21 | 22 | (define-task-manager-command (com-refresh :name "Refresh" 23 | :keystroke (#\r :meta)) 24 | () 25 | (with-slots (thread-num-history memory-usage-history history-position) 26 | clim:*application-frame* 27 | (setf (elt thread-num-history history-position) (length (bt:all-threads))) 28 | (setf (elt memory-usage-history history-position) (mem-usage)) 29 | (setf history-position (mod (+ 1 history-position) history-size))) 30 | (let ((pane (clim:find-pane-named clim:*application-frame* 'thread-display))) 31 | (clim:change-space-requirements pane :width 0 :height 0 32 | :min-width 0 :min-height 0) 33 | (clim:redisplay-frame-pane clim:*application-frame* 34 | pane 35 | :force-p t)) 36 | (let ((pane (clim:find-pane-named clim:*application-frame* 'history-display))) 37 | (clim:change-space-requirements pane :width 0 :height 0 38 | :min-width 0 :min-height 0) 39 | (clim:redisplay-frame-pane clim:*application-frame* 40 | pane 41 | :force-p t))) 42 | 43 | 44 | (define-task-manager-command (com-clear-interactor 45 | :name "Clear interactor history" 46 | :keystroke (#\c :meta)) 47 | () 48 | (let ((pane (clim:find-pane-named clim:*application-frame* 'interact))) 49 | (clim:window-clear pane))) 50 | 51 | -------------------------------------------------------------------------------- /roswell/mcclim-desktop.ros: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | #|-*- mode:lisp -*-|# 3 | #| 4 | exec ros -m mcclim-desktop -- $0 "$@" 5 | |# 6 | 7 | (require :sb-introspect) 8 | (require :log4cl) 9 | (require :mcclim) 10 | (require :mcclim-desktop) 11 | 12 | (defun main (&optional (backend "clxf") &rest argv) 13 | (declare (ignorable argv)) 14 | #+ sbcl (sb-ext:enable-debugger) 15 | (when backend 16 | (cond ((equal "clxf" backend) 17 | (require :mcclim-fonts/clx-truetype) 18 | (setf clim:*default-server-path* (list :clx :font-renderer 'mcclim-truetype:truetype-font-renderer))) 19 | ((equal "clxs" backend) 20 | (require :mcclim-fonts/clx-truetype) 21 | (setf clim:*default-server-path* (list :clx :mirroring :single))) 22 | ((equal "clxttf" backend) 23 | (setf clim:*default-server-path* (list :clx-ttf))) 24 | ((equal "clx-fb" backend) 25 | (require :mcclim-fonts/clx-truetype) 26 | (require :mcclim-clx-fb) 27 | (setf clim:*default-server-path* (list :clx-fb))) 28 | ((equal "cldk-clx" backend) 29 | (require :mcclim-cldk/clx) 30 | (require :cldk-clx) 31 | (setf clim:*default-server-path* (list :clx-cldk :cldk-driver :clx))) 32 | ((equal "cldk-sdl2" backend) 33 | (require :mcclim-cldk/sdl2) 34 | (require :cldk-sdl2) 35 | (setf clim:*default-server-path* (list :sdl2-cldk :cldk-driver :sdl2))) 36 | (t 37 | (format t "Usage: ~A [clxf | clxs | clx-fb | cldk-clx | cldk-sdl2 ]~%" (file-namestring *load-pathname*)) 38 | (ros:quit 1)))) 39 | (desktop:configure) 40 | (desktop:run-app "console") 41 | (loop while (> (length (bt:all-threads)) 42 | (cond 43 | ((equal "clx-fb" backend) 4) 44 | ((equal "cldk-clx" backend) 4) 45 | ((equal "cldk-sdl2" backend) 5) 46 | (t 47 | 3))) 48 | do 49 | (bt:join-thread (find-if-not #'(lambda (thread) 50 | (eq thread (bt:current-thread))) 51 | (bt:all-threads))))) 52 | 53 | -------------------------------------------------------------------------------- /Core/src/api.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | ;;;; 4 | ;;;; API 5 | ;;;; 6 | 7 | ;;; 8 | ;;; Application 9 | ;;; 10 | 11 | (defun make-application (name type &rest args) 12 | (apply #'make-instance type :name (string-downcase name) args)) 13 | 14 | (defun register-application (name type &rest args) 15 | (register-new-application 16 | (apply #'make-application name type args))) 17 | 18 | (defun find-application (application-designator &optional (errorp t)) 19 | (or (find-registered-application application-designator nil) 20 | (discover-application 21 | (typecase application-designator 22 | (string 23 | application-designator) 24 | (symbol 25 | (string-downcase (string application-designator))))))) 26 | 27 | (defun find-applications () 28 | (discover-applications)) 29 | 30 | (defun applications () 31 | (registered-applications)) 32 | 33 | (defun map-applications (fn) 34 | (map-registered-applications fn)) 35 | 36 | (defun run-app (application &rest args) 37 | (apply #'run-application (find-application application) args)) 38 | 39 | (defun launch-app (application &key args cb-fn) 40 | (funcall #'launch-application (find-application application) :args args :cb-fn cb-fn)) 41 | 42 | (defun configure-app (application &optional force-p) 43 | (configure-application (find-application application) force-p)) 44 | 45 | (defun load-app (application &optional force-p) 46 | (load-application (find-application application) force-p)) 47 | 48 | (defun install-app (application &optional force-p) 49 | (install-application (find-application application) force-p)) 50 | 51 | (defun use-application-as-debugger (application-designator) 52 | (let ((app (find-application application-designator))) 53 | (unless (application-configured-p app) 54 | (configure-application app)) 55 | (use-debugger (desk:application-debugger-fn app)))) 56 | 57 | (defun use-application-as-external-debugger (application-designator) 58 | (let ((app (find-application application-designator))) 59 | (unless (application-configured-p app) 60 | (configure-application app)) 61 | (use-external-debugger (desk:application-debugger-fn app)))) 62 | -------------------------------------------------------------------------------- /Apps/launcher/gui/commands.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-launcher) 2 | 3 | 4 | (define-desktop-launcher-command (com-quit :menu t 5 | :name "Quit" 6 | :keystroke (#\q :meta)) 7 | () 8 | (clim:frame-exit clim:*application-frame*)) 9 | 10 | (define-desktop-launcher-command (com-refresh :menu t 11 | :name "Refresh" 12 | :keystroke (#\r :meta)) 13 | () 14 | (refresh-applications) 15 | (update-applications)) 16 | 17 | (define-desktop-launcher-command (com-clear 18 | :name "Clear" 19 | :keystroke (#\c :meta)) 20 | () 21 | (let ((pane (or (clim:find-pane-named clim:*application-frame* 'log-display) 22 | (clim:find-pane-named clim:*application-frame* 'interactor)))) 23 | (clim:window-clear pane))) 24 | 25 | 26 | 27 | 28 | ;; traslators 29 | 30 | (clim:define-presentation-to-command-translator launch-app 31 | (application deski::com-launch-app desktop-launcher 32 | :documentation "launch app" 33 | :gesture :select 34 | :tester ((app) (not (application-requires-args-p app)))) 35 | (app) 36 | (list app)) 37 | 38 | (clim:define-presentation-to-command-translator open-app-home-page 39 | (application deski::com-open-app-home-page desktop-launcher 40 | :gesture :help 41 | :documentation "open app home page" 42 | :tester ((app) (declare (ignore app)) t)) 43 | (app) 44 | (list app)) 45 | 46 | (clim:define-presentation-to-command-translator edit-app-def-file 47 | (application deski::com-edit-app-def-file desktop-launcher 48 | :gesture :help 49 | :documentation "edit app file" 50 | :tester ((app) (declare (ignore app)) t)) 51 | (app) 52 | (list app)) 53 | 54 | (clim:define-presentation-to-command-translator edit-app-config-file 55 | (application deski::com-edit-app-config-file desktop-launcher 56 | :gesture :help 57 | :documentation "edit app config" 58 | :tester ((app) (declare (ignore app)) t)) 59 | (app) 60 | (list app)) 61 | 62 | (clim:define-presentation-to-command-translator edit-app-style-file 63 | (application deski::com-edit-app-style-file desktop-launcher 64 | :gesture :help 65 | :documentation "edit app style" 66 | :tester ((app) (declare (ignore app)) t)) 67 | (app) 68 | (list app)) 69 | 70 | 71 | -------------------------------------------------------------------------------- /Core/src/logger.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | ;;;; 4 | ;;;; Logging 5 | ;;;; 6 | 7 | (defvar *logger* nil 8 | "The current logger") 9 | 10 | ;;; functions 11 | 12 | (defun use-logger (logger) 13 | (setq *logger* logger)) 14 | 15 | ;;; macros 16 | 17 | (defmacro with-logger ((logger) &body body) 18 | `(let ((*logger* ,logger)) 19 | ,@body)) 20 | 21 | ;;;; 22 | ;;;; logger class 23 | ;;;; 24 | 25 | (defclass logger () 26 | ((lock :initform (bt:make-lock "logger")))) 27 | 28 | ;;; 29 | ;;; logger protocols 30 | ;;; 31 | 32 | (defgeneric logger-log-info (logger msg)) 33 | (defgeneric logger-log-warn (logger msg)) 34 | (defgeneric logger-log-error (logger msg)) 35 | 36 | ;;; methods 37 | (defmethod logger-log-info :around ((logger logger) msg) 38 | (declare (ignore msg)) 39 | (with-slots (lock) logger 40 | (bt:with-lock-held (lock) 41 | (call-next-method)))) 42 | 43 | (defmethod logger-log-warn :around ((logger logger) msg) 44 | (declare (ignore msg)) 45 | (with-slots (lock) logger 46 | (bt:with-lock-held (lock) 47 | (call-next-method)))) 48 | 49 | (defmethod logger-log-error :around ((logger logger) msg) 50 | (declare (ignore msg)) 51 | (with-slots (lock) logger 52 | (bt:with-lock-held (lock) 53 | (call-next-method)))) 54 | 55 | ;;;; 56 | ;;;; simple functions 57 | ;;;; 58 | 59 | (defun make-logger (type &rest args) 60 | (apply #'make-instance type args)) 61 | 62 | (defun log-info (msg) 63 | (logger-log-info *logger* msg)) 64 | 65 | (defun log-warn (msg) 66 | (logger-log-warn *logger* msg)) 67 | 68 | (defun log-error (msg) 69 | (logger-log-error *logger* msg)) 70 | 71 | ;;;; 72 | ;;;; logger mixin 73 | ;;;; 74 | 75 | (defclass stream-logger-mixin (logger) 76 | ((stream :initarg :stream 77 | :accessor logger-stream 78 | :initform *trace-output*))) 79 | 80 | (defmethod logger-log-info ((logger stream-logger-mixin) msg) 81 | (with-slots (stream) logger 82 | (format stream "Info: ~A~%" msg))) 83 | 84 | (defmethod logger-log-warn ((logger stream-logger-mixin) msg) 85 | (with-slots (stream) logger 86 | (format stream "Warn: ~A~%" msg))) 87 | 88 | (defmethod logger-log-error ((logger stream-logger-mixin) msg) 89 | (with-slots (stream) logger 90 | (format stream "Error: ~A~%" msg))) 91 | 92 | ;;;; 93 | ;;;; standard logger 94 | ;;;; 95 | 96 | (defclass standard-logger (stream-logger-mixin logger) 97 | ()) 98 | -------------------------------------------------------------------------------- /dot-mcclim-desktop/config/climacs-config.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-user) 2 | 3 | (setf (application-entry-fn *application*) 4 | #'(lambda (app &rest args) 5 | (declare (ignore app)) 6 | (if (null args) 7 | (climacs:climacs) 8 | (climacs::%edit-file (car args))))) 9 | 10 | ;;; 11 | ;;; patch 12 | ;;; 13 | (in-package :climacs) 14 | 15 | (defun %edit-file (thing &rest args 16 | &key (process-name "Climacs") (width 900) (height 400) 17 | (text-style *climacs-text-style*)) 18 | "Edit THING in an existing climacs process or start a new one. THING 19 | can be a filename (edit the file) or symbol (edit its function definition)." 20 | (declare (ignore process-name width height text-style)) 21 | (let ((climacs-frame (find-climacs-frame)) 22 | (command 23 | (typecase thing 24 | (null nil) 25 | (symbol (list 'drei-lisp-syntax::com-edit-definition thing)) 26 | ((or string pathname) 27 | (truename thing) ; raise file-error if file doesn't exist 28 | (list 'esa-io::com-find-file thing)) 29 | (t (error 'type-error :datum thing 30 | :expected-type '(or null string pathname symbol)))))) 31 | (if climacs-frame 32 | (when command 33 | (execute-frame-command climacs-frame command)) 34 | (apply #'climacs-common command args))) 35 | t) 36 | 37 | 38 | ;;; 39 | ;;; clipboard 40 | ;;; 41 | 42 | (in-package drei) 43 | 44 | (define-command (com-paste-x-clipboard :name t :command-table drei:editing-table) () 45 | (flexichain:insert-sequence (point) (desktop-sys:paste-from-x11-clipboard))) 46 | 47 | (define-command (com-copy-x-clipboard :name t :command-table drei:view-table) () 48 | (desktop-sys:copy-to-x11-clipboard (coerce (kill-ring-yank *kill-ring*) 'string))) 49 | 50 | (esa-io::set-key 'com-paste-x-clipboard 'drei:editing-table '((#\y :META :CONTROL))) 51 | (esa-io::set-key 'com-copy-x-clipboard 'drei:view-table '((#\w :META :CONTROL))) 52 | 53 | ;;; 54 | ;;; Apropos navigator 55 | ;;; 56 | 57 | (in-package :desktop-user) 58 | 59 | (clim:define-command (com-apropos-navigator 60 | :name t 61 | :command-table drei:editing-table) () 62 | (let ((return-point (drei:point)) 63 | (return-values (run-app "apropos-navigator"))) 64 | (when return-values 65 | (flexichain:insert-sequence return-point 66 | (write-to-string return-values))))) 67 | 68 | (esa-io::set-key 'com-apropos-navigator 69 | 'drei-lisp-syntax::lisp-table '((#\s :meta :control))) 70 | 71 | -------------------------------------------------------------------------------- /Resource/src/debugger.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | (defclass minimized-stack-frame-view (clim:textual-view)()) 4 | (defclass maximized-stack-frame-view (clim:textual-view)()) 5 | 6 | (defparameter +minimized-stack-frame-view+ 7 | (make-instance 'minimized-stack-frame-view)) 8 | (defparameter +maximized-stack-frame-view+ 9 | (make-instance 'maximized-stack-frame-view)) 10 | 11 | 12 | ;;; 13 | ;;; Clim resource for debugger 14 | ;;; 15 | 16 | (defclass debugger-info () 17 | ((the-condition :accessor the-condition 18 | :initarg :the-condition) 19 | (condition-message :accessor condition-message 20 | :initarg :condition-message) 21 | (type-of-condition :accessor type-of-condition 22 | :initarg :type-of-condition) 23 | (condition-extra :accessor condition-extra 24 | :initarg :condition-extra) 25 | (restarts :accessor restarts 26 | :initarg :restarts) 27 | (backtrace :accessor backtrace 28 | :initarg :backtrace))) 29 | 30 | 31 | (defclass stack-frame () 32 | ((clim-view :accessor view :initform +minimized-stack-frame-view+) 33 | (frame-string :accessor frame-string 34 | :initarg :frame-string) 35 | (frame-no :accessor frame-no 36 | :initarg :frame-no) 37 | (frame-variables :accessor frame-variables 38 | :initarg :frame-variables))) 39 | 40 | (defun compute-backtrace (start end) 41 | (loop for frame in (swank-backend::compute-backtrace start end) 42 | for frame-no from 0 43 | collect (make-instance 44 | 'stack-frame 45 | :frame-string (let ((*print-pretty* nil)) 46 | (with-output-to-string (stream) 47 | (swank-backend::print-frame frame stream))) 48 | :frame-no frame-no 49 | :frame-variables (swank-backend::frame-locals frame-no)))) 50 | 51 | (defmethod expand-backtrace ((info debugger-info) (value integer)) 52 | (with-slots (backtrace) info 53 | (setf backtrace (compute-backtrace 0 (+ (length backtrace) 10))))) 54 | 55 | 56 | (defun make-debugger-info (condition) 57 | (make-instance 58 | 'debugger-info 59 | :the-condition condition 60 | :type-of-condition (type-of condition) 61 | :condition-message (swank::safe-condition-message condition) 62 | :condition-extra (swank::condition-extras condition) 63 | :restarts (compute-restarts) 64 | :backtrace (compute-backtrace 0 20))) 65 | 66 | 67 | ;;; 68 | ;;; presentations 69 | ;;; 70 | 71 | (clim:define-presentation-type restart ()) 72 | 73 | 74 | ;; Used to provide the clim frame with the condition info that 75 | ;; triggered the debugger. 76 | 77 | (defparameter *condition* nil) 78 | 79 | (defmacro bold ((stream) &body body) 80 | `(clim:with-text-face (,stream :bold) 81 | ,@body)) 82 | 83 | 84 | (clim:define-presentation-method clim:present (object (type restart) stream 85 | (view clim:textual-view) 86 | &key acceptably for-context-type) 87 | (declare (ignore acceptably for-context-type)) 88 | (bold (stream) (format t "~A" (restart-name object)))) 89 | 90 | (clim:define-presentation-method clim:accept ((type restart) stream view &key) 91 | (declare (ignore view)) 92 | (let ((condition-info *condition*)) 93 | (values 94 | (clim:completing-from-suggestions (stream :partial-completers '(#\Space)) 95 | (loop 96 | for r in (restarts condition-info) 97 | for i from 0 98 | do 99 | (clim:suggest (format nil "~A: ~A" i (restart-name r)) r)))))) 100 | -------------------------------------------------------------------------------- /Resource/src/thread.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | ;;; 4 | ;;; Clim resource for threads 5 | ;;; 6 | 7 | (defun thread->textual-string (thread) 8 | (bt:thread-name thread)) 9 | 10 | (defun thread-frames (thread) 11 | (let ((frames nil)) 12 | (clim:map-over-frames #'(lambda (frame) 13 | (when (and 14 | (typep frame 'clim:standard-application-frame) 15 | (eq (climi::frame-process frame) 16 | thread)) 17 | (push frame frames)))) 18 | frames)) 19 | 20 | ;;; presentation 21 | 22 | (clim:define-presentation-type thread ()) 23 | 24 | (clim:define-presentation-method clim:presentation-typep (object (type thread)) 25 | (bt:threadp object)) 26 | 27 | (clim:define-presentation-method clim:present (object (type thread) stream 28 | (view clim:textual-view) 29 | &key acceptably for-context-type) 30 | (declare (ignore acceptably for-context-type)) 31 | (princ (thread->textual-string object) stream)) 32 | 33 | (clim:define-presentation-method clim:accept ((type thread) stream view &key) 34 | (declare (ignore view)) 35 | (values 36 | (clim:completing-from-suggestions (stream :partial-completers '(#\Space)) 37 | (mapcar #'(lambda (thread) 38 | (clim:suggest (thread->textual-string thread) thread)) 39 | (bt:all-threads))))) 40 | 41 | ;;; command table 42 | 43 | (clim:define-command-table thread-command-table) 44 | 45 | ;;; translators 46 | 47 | (clim:define-presentation-translator expression-to-thread 48 | (clim:expression thread thread-command-table 49 | :documentation "expression to thread" 50 | :tester ((object) (clim:presentation-typep object 'thread)) 51 | :tester-definitive t) 52 | (object) 53 | object) 54 | 55 | (clim:define-presentation-translator thread-to-expression 56 | (thread clim:expression thread-command-table 57 | :documentation "thread to expression") 58 | (object) 59 | object) 60 | 61 | ;;; commands 62 | 63 | (clim:define-command (com-break-thread :command-table thread-command-table 64 | :name t 65 | :menu t) 66 | ((thread 'thread)) 67 | (bt:interrupt-thread thread 68 | #'(lambda () 69 | (break)))) 70 | 71 | (clim:define-command (com-destroy-thread :command-table thread-command-table 72 | :name t 73 | :menu t) 74 | ((thread 'thread)) 75 | (bt:destroy-thread thread)) 76 | 77 | (clim:define-command (com-inspect-thread :command-table thread-command-table 78 | :name t 79 | :menu t) 80 | ((thread 'thread)) 81 | (launch-application (find-application "clouseau") 82 | :args (list thread))) 83 | 84 | (clim:define-command (com-list-threads :command-table thread-command-table 85 | :name nil 86 | :menu nil) 87 | () 88 | (dolist (thread (bt:all-threads)) 89 | (fresh-line) 90 | (clim:with-output-as-presentation (t thread (deski::desktop-presentation-type-of thread) 91 | :allow-sensitive-inferiors nil 92 | :single-box t) 93 | (clim:present thread 'clim:expression)))) 94 | 95 | ;;; translators 96 | 97 | (clim:define-presentation-to-command-translator break-thread 98 | (thread com-break-thread thread-command-table 99 | :gesture :help 100 | :documentation "break") 101 | (thread) 102 | (list thread)) 103 | 104 | (clim:define-presentation-to-command-translator destroy-thread 105 | (thread com-destroy-thread thread-command-table 106 | :gesture :help 107 | :documentation "destroy") 108 | (thread) 109 | (list thread)) 110 | 111 | (clim:define-presentation-to-command-translator inspect-thread 112 | (thread com-inspect-thread thread-command-table 113 | :gesture :help 114 | :documentation "inspect") 115 | (thread) 116 | (list thread)) 117 | 118 | ;;; UTILITY 119 | 120 | #+sbcl 121 | (defmethod desktop-presentation-type-of ((thread sb-thread:thread)) 122 | 'thread) 123 | -------------------------------------------------------------------------------- /Apps/apropos/gui/commands.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-apropos) 2 | 3 | ;;; 4 | ;;; command tables 5 | ;;; 6 | 7 | (clim:make-command-table 'edit-menu) 8 | 9 | ;;; 10 | ;;; commands 11 | ;;; 12 | 13 | (define-apropos-navigator-command (com-quit :menu t 14 | :name "Quit" 15 | :keystroke (#\q :meta)) 16 | () 17 | (%update-return-values) 18 | (clim:frame-exit clim:*application-frame*)) 19 | 20 | ;;; edit 21 | 22 | (clim:define-command (com-edit-select-all :command-table edit-menu 23 | :menu t 24 | :name "Select All" 25 | :keystroke (#\a :meta :control)) 26 | () 27 | (with-slots (selected-values iapropos) clim:*application-frame* 28 | (setf selected-values (iapropos-matching-symbols iapropos))) 29 | (%maybe-update-output-display)) 30 | 31 | (clim:define-command (com-edit-select-none :command-table edit-menu 32 | :menu t 33 | :name "Select None" 34 | :keystroke (#\n :meta :control)) 35 | () 36 | (with-slots (selected-values iapropos) clim:*application-frame* 37 | (setf selected-values nil)) 38 | (%maybe-update-output-display)) 39 | 40 | (clim:define-command (com-edit-copy-to-kill-ring :command-table edit-menu 41 | :menu t 42 | :name "Copy To Kill Ring" 43 | :keystroke (#\k :meta :control)) 44 | () 45 | (setf (clim:port-keyboard-input-focus (clim:port clim:*application-frame*)) 46 | (car (clim:sheet-children 47 | (clim:find-pane-named clim:*application-frame* 'symbol-regex-text-field)))) 48 | (%update-return-values) 49 | (desktop-sys:copy-to-kill-ring (format nil "~A" *return-values*))) 50 | 51 | (clim:define-command (com-edit-copy-to-clipboard :command-table edit-menu 52 | :menu t 53 | :name "Copy To Clipboard" 54 | :keystroke (#\c :meta :control)) 55 | () 56 | (%update-return-values) 57 | (desktop-sys:copy-to-x11-clipboard (format nil "~S" *return-values*))) 58 | 59 | 60 | ;;; keystroke 61 | 62 | (clim:define-command (com-edit-move-focus :command-table edit-menu 63 | :menu nil 64 | :keystroke (#\Tab)) 65 | () 66 | (let ((sym-sheet (car (clim:sheet-children 67 | (clim:find-pane-named clim:*application-frame* 'symbol-regex-text-field)))) 68 | (pac-sheet (car (clim:sheet-children 69 | (clim:find-pane-named clim:*application-frame* 'package-regex-text-field))))) 70 | (setf (clim:port-keyboard-input-focus (clim:port clim:*application-frame*)) 71 | (if (eq 72 | (clim:port-keyboard-input-focus (clim:port clim:*application-frame*)) 73 | sym-sheet) 74 | pac-sheet 75 | sym-sheet)))) 76 | 77 | ;;; gesture :select 78 | 79 | (define-apropos-navigator-command (com-select-symbol :name "Select Symbol") 80 | ((sym 'symbol :gesture :select)) 81 | (with-slots (selected-values selected-action-option) clim:*application-frame* 82 | (if (eq selected-action-option :single) 83 | (setf selected-values (list sym)) 84 | (if (member sym selected-values) 85 | (setf selected-values (remove sym selected-values)) 86 | (setf selected-values (remove-duplicates (push sym selected-values)))))) 87 | (with-fixed-vertical-scroll-bar (clim:find-pane-named 88 | clim:*application-frame* 'symbol-result-display) 89 | (%maybe-update-symbol-result-display)) 90 | (%maybe-update-output-display)) 91 | 92 | (define-apropos-navigator-command (com-select-package 93 | :name "Select Package") 94 | ((pack 'package :gesture :select)) 95 | (setf (clim:gadget-value 96 | (clim:find-pane-named clim:*application-frame* 'package-regex-text-field)) 97 | (format nil "^~A$" (package-name pack)))) 98 | 99 | (define-apropos-navigator-command (com-inspect-object 100 | :name "Inspect Object") 101 | ((object 'object :gesture :select)) 102 | (clouseau:inspect object)) 103 | 104 | (define-apropos-navigator-command (com-edit-definition :name "Edit Definition") 105 | ((loc 'source-location :gesture :select)) 106 | (climacs:edit-file (car loc)) 107 | (unless (climacs::find-climacs-frame) 108 | (sleep 1)) 109 | (clim:execute-frame-command (climacs::find-climacs-frame) 110 | (list 'drei-commands::com-goto-position (cdr loc)))) 111 | -------------------------------------------------------------------------------- /Resource/src/frame.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | ;;; 4 | ;;; Clim resource for application frames 5 | ;;; 6 | 7 | (defun frame->textual-string (frame) 8 | (if (typep frame 'clim:standard-application-frame) 9 | (clim:frame-pretty-name frame) 10 | (format nil "~A" frame))) 11 | 12 | ;; presentations 13 | 14 | (clim:define-presentation-type frame ()) 15 | 16 | (clim:define-presentation-method clim:presentation-typep (object (type frame)) 17 | (typep object 'clim:application-frame)) 18 | 19 | (clim:define-presentation-method clim:present 20 | (object (type frame) stream 21 | (view clim:textual-view) 22 | &key acceptably for-context-type) 23 | (declare (ignore acceptably for-context-type)) 24 | (princ (frame->textual-string object) stream)) 25 | 26 | (clim:define-presentation-method clim:accept ((type frame) stream view &key) 27 | (declare (ignore view)) 28 | (values 29 | (clim:completing-from-suggestions (stream :partial-completers '(#\Space)) 30 | (clim:map-over-frames #'(lambda (o) 31 | (clim:suggest (frame->textual-string o) o)))))) 32 | 33 | ;; command table 34 | 35 | (clim:define-command-table frame-command-table) 36 | 37 | ;;; translators 38 | 39 | (clim:define-presentation-translator expression-to-frame 40 | (clim:expression frame frame-command-table 41 | :documentation "expression to frame" 42 | :tester ((object) (clim:presentation-typep object 'frame)) 43 | :tester-definitive t) 44 | (object) 45 | object) 46 | 47 | (clim:define-presentation-translator frame-to-expression 48 | (frame clim:expression frame-command-table 49 | :documentation "frame to expression" 50 | :tester-definitive t) 51 | (object) 52 | object) 53 | 54 | ;; commands 55 | 56 | (clim:define-command (com-exit-frame :command-table frame-command-table 57 | :name t 58 | :menu t) 59 | ((frame 'frame)) 60 | (clim:frame-exit frame)) 61 | 62 | (clim:define-command (com-raise-frame :command-table frame-command-table 63 | :name t 64 | :menu t) 65 | ((frame 'frame)) 66 | (clim:raise-frame frame)) 67 | 68 | (clim:define-command (com-inspect-frame :command-table frame-command-table 69 | :name t 70 | :menu t) 71 | ((frame 'frame)) 72 | (launch-application (find-application "clouseau") 73 | :args (list frame))) 74 | 75 | (clim:define-command (com-break-frame :command-table frame-command-table 76 | :name t 77 | :menu t) 78 | ((frame 'frame)) 79 | (when (and 80 | (typep frame 'clim:standard-application-frame) 81 | (climi::frame-process frame)) 82 | (bt:interrupt-thread (climi::frame-process frame) 83 | #'(lambda () 84 | (break))))) 85 | 86 | (clim:define-command (com-list-frames :command-table frame-command-table 87 | :name nil 88 | :menu nil) 89 | () 90 | (clim:map-over-frames 91 | #'(lambda (frame) 92 | (fresh-line) 93 | (clim:with-output-as-presentation (t frame 94 | (deski::desktop-presentation-type-of frame) 95 | :allow-sensitive-inferiors nil 96 | :single-box t) 97 | (clim:present frame 'clim:expression))))) 98 | 99 | ;; translators 100 | 101 | (clim:define-presentation-to-command-translator break-frame 102 | (frame com-break-frame frame-command-table 103 | :gesture :help 104 | :tester ((object) (climi::frame-process object)) 105 | :documentation "break") 106 | (frame) 107 | (list frame)) 108 | 109 | (clim:define-presentation-to-command-translator exit-frame 110 | (frame com-exit-frame frame-command-table 111 | :gesture :help 112 | :documentation "exit") 113 | (frame) 114 | (list frame)) 115 | 116 | (clim:define-presentation-to-command-translator raise-frame 117 | (frame com-raise-frame frame-command-table 118 | :gesture :help 119 | :tester ((object) (climi::frame-process object)) 120 | :documentation "raise") 121 | (frame) 122 | (list frame)) 123 | 124 | (clim:define-presentation-to-command-translator inspect-frame 125 | (frame com-inspect-frame frame-command-table 126 | :gesture :select 127 | :documentation "inspect") 128 | (frame) 129 | (list frame)) 130 | 131 | (defmethod desktop-presentation-type-of ((frame clim:application-frame)) 132 | 'frame) 133 | -------------------------------------------------------------------------------- /packages.lisp: -------------------------------------------------------------------------------- 1 | (in-package :common-lisp-user) 2 | 3 | (defpackage :desktop 4 | (:use :common-lisp) 5 | (:nicknames :desk) 6 | (:export 7 | ;; initialization 8 | #:initialize 9 | #:configure 10 | 11 | ;; debugger 12 | #:install-debugger-globally 13 | #:use-debugger 14 | #:use-external-debugger 15 | 16 | ;; logger 17 | #:use-logger 18 | #:make-logger 19 | #:standard-logger 20 | #:log-info 21 | #:log-warn 22 | #:log-error 23 | 24 | ;; global application variables 25 | #:*application* 26 | 27 | ;; application classes 28 | #:standard-cl-application 29 | #:standard-mcclim-application 30 | #:standard-shell-application 31 | #:standard-alias-application 32 | #:standard-debugger-application 33 | #:standard-mcclim-debugger-application 34 | 35 | ;; application slots 36 | #:application-name 37 | #:application-pretty-name 38 | #:application-icon 39 | #:application-menu-p 40 | #:application-requires-args-p 41 | #:application-configured-p 42 | #:application-home-page 43 | #:application-git-repo 44 | #:application-system-name 45 | #:application-debug-system-p 46 | #:application-loaded-p 47 | #:application-installed-p 48 | #:application-frame-class 49 | #:application-link-reference 50 | #:application-entry-fn 51 | #:application-make-command-fn 52 | #:application-debugger-fn 53 | ;; application protocols 54 | #:run-application 55 | #:launch-application 56 | #:configure-application 57 | #:load-application 58 | #:install-application 59 | #:application-file 60 | #:application-config-file 61 | #:application-style-file 62 | 63 | ;; refresh 64 | #:refresh-application 65 | #:refresh-applications 66 | 67 | ;; standard pathname 68 | 69 | ;; API 70 | #:make-application 71 | #:register-application 72 | #:find-application 73 | #:find-applications 74 | #:applications 75 | #:map-applications 76 | #:run-app 77 | #:launch-app 78 | #:configure-app 79 | #:load-app 80 | #:install-app 81 | #:use-application-as-debugger 82 | #:use-application-as-external-debugger 83 | )) 84 | 85 | (defpackage :desktop-extensions 86 | (:use :desktop :common-lisp) 87 | (:export 88 | ;; debugger 89 | #:*debugger* 90 | #:*external-debugger* 91 | 92 | ;; logger 93 | #:*logger* 94 | #:with-logger 95 | #:logger-log-info 96 | #:logger-log-warn 97 | #:logger-log-error 98 | #:logger 99 | #:stream-logger-mixin 100 | #:logger-stream 101 | 102 | ;; application mixin 103 | #:simple-application-mixin 104 | #:simple-cl-application-mixin 105 | #:simple-shell-application-mixin 106 | #:standard-application-mixin 107 | #:standard-cl-application-mixin 108 | #:simple-debugger-application-mixin 109 | 110 | ;; application 111 | #:application 112 | #:cl-application 113 | #:mcclim-application 114 | #:link-application 115 | #:alias-application 116 | #:proxy-application 117 | #:shell-application 118 | #:need-reconfigure-application 119 | #:load-application-config-file 120 | #:load-application-style-file 121 | ;; applications 122 | #:*registered-applications* 123 | #:register-new-application 124 | #:remove-registered-application 125 | #:remove-registered-applications 126 | #:find-registered-application 127 | #:registered-applications 128 | #:map-registered-applications 129 | ;; standard pathname 130 | #:find-user-file 131 | #:create-user-file 132 | #:find-user-files 133 | #:find-system-file 134 | #:find-system-files 135 | #:find-system-directories 136 | #:find-file 137 | ;; discovering 138 | #:discover-application 139 | #:discover-applications 140 | )) 141 | 142 | (defpackage :desktop-sys 143 | (:use :common-lisp) 144 | (:export 145 | #:copy-to-x11-clipboard 146 | #:paste-from-x11-clipboard 147 | #:copy-to-kill-ring 148 | #:paste-from-kill-ring 149 | #:take-x11-screenshot 150 | )) 151 | 152 | (defpackage :desktop-internals 153 | (:use :desktop :desktop-extensions :desktop-sys :common-lisp) 154 | (:nicknames :deski) 155 | (:export 156 | #:frame-command-table 157 | #:thread-command-table 158 | #:application-command-table 159 | #:edit-application-command-table)) 160 | 161 | (defpackage :desktop-user 162 | (:use :desktop :clim :clim-lisp) 163 | (:nicknames :desk-user)) 164 | -------------------------------------------------------------------------------- /Apps/apropos/src/utility.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-apropos) 2 | 3 | ;;; 4 | ;;; Constants 5 | ;;; 6 | 7 | (defparameter *symbol-bounding-types* '(:variable :function :generic-function 8 | :class :macro :setf :type)) 9 | 10 | ;;; 11 | ;;; utility functions 12 | ;;; 13 | 14 | (defun symbol-external-p (symbol) 15 | "Return t only if the symbol is external" 16 | (swank::symbol-external-p symbol)) 17 | 18 | (defun symbol-bound-to (symbol type) 19 | (ccase type 20 | (:variable 21 | (and symbol (boundp symbol))) 22 | (:function 23 | (fboundp symbol)) 24 | (:macro 25 | (macro-function symbol)) 26 | (:class 27 | (find-class symbol nil)) 28 | (:generic-function 29 | (and (fboundp symbol) 30 | (typep (symbol-function symbol) 'generic-function))) 31 | ((:setf :type) 32 | (not (eq (getf (swank/backend::describe-symbol-for-emacs symbol) type 'cl:t) 33 | t))))) 34 | 35 | (defun symbol-documentation (symbol type) 36 | (let ((doc (getf (swank/backend::describe-symbol-for-emacs symbol) 37 | (case type 38 | (:class 39 | :type) 40 | (:generic-function 41 | #+sbcl :generic-function 42 | #+ccl :function) 43 | (:macro 44 | #+sbcl :macro 45 | #+ccl :function) 46 | (otherwise 47 | type)) 48 | 'cl:t))) 49 | (if (member doc '(t nil :NOT-DOCUMENTED)) 50 | nil 51 | doc))) 52 | 53 | (defun list-symbol-bounding-types (symbol) 54 | (let ((types (remove-if #'(lambda (type) 55 | (not (symbol-bound-to symbol type))) 56 | *symbol-bounding-types*))) 57 | (cond 58 | ((member :generic-function types) 59 | (remove :function types)) 60 | ((member :macro types) 61 | (remove :function types)) 62 | (t 63 | types)))) 64 | 65 | (defun symbol-object (symbol type) 66 | (ccase type 67 | (:variable 68 | (symbol-value symbol)) 69 | (:function 70 | (when (fboundp symbol) 71 | (symbol-function symbol))) 72 | (:macro 73 | (macro-function symbol)) 74 | (:class 75 | (when (find-class symbol nil) 76 | (find-class symbol))) 77 | (:generic-function 78 | (when (fboundp symbol) 79 | (symbol-function symbol))) 80 | (:setf 81 | #+sbcl (swank/sbcl::setf-expander symbol) 82 | #+ccl nil) 83 | (:type 84 | nil))) 85 | 86 | (defun symbol-location (symbol type) 87 | (let ((definitions (swank::find-definitions symbol))) 88 | (flet ((convert (ty) 89 | (let ((loc 90 | (car (cdr (find-if #'(lambda (x) (eq ty (caar x))) definitions))))) 91 | (when (eq (car loc) :location) 92 | (cons (cadr (assoc :file (cdr loc))) 93 | (cadr (assoc :position (cdr loc)))))))) 94 | #+sbcl 95 | (ccase type 96 | (:variable 97 | (convert 'defvar)) 98 | (:function 99 | (convert 'defun)) 100 | (:generic-function 101 | (convert 'defgeneric)) 102 | (:macro 103 | (convert 'defmacro)) 104 | (:class 105 | (convert 'defclass)) 106 | (:setf 107 | (convert 'define-setf-expander)) 108 | (:type 109 | (convert 'defclass))) 110 | #+ccl 111 | (ccase type 112 | (:variable 113 | (convert 'variable)) 114 | (:function 115 | (convert 'defun)) 116 | (:generic-function 117 | (convert 'defgeneric)) 118 | (:macro 119 | (convert 'defmacro)) 120 | (:class 121 | (convert 'defclass)) 122 | (:setf 123 | (convert 'define-setf-expander)) 124 | (:type 125 | (convert 'defclass)))))) 126 | 127 | (defun symbol-description (symbol type) 128 | (with-output-to-string (*standard-output*) 129 | (case type 130 | ((:variable nil) 131 | (describe symbol)) 132 | (:function 133 | (when (fboundp symbol) 134 | (describe (symbol-function symbol)))) 135 | (:macro 136 | (when (macro-function symbol) 137 | (describe (macro-function symbol)))) 138 | (:class 139 | (when (find-class symbol nil) 140 | (describe (find-class symbol)))) 141 | (:generic-function 142 | (when (fboundp symbol) 143 | (describe (symbol-function symbol)))) 144 | (:setf 145 | #+sbcl (when (sb-int:info :setf :expander symbol) 146 | (describe (sb-int:info :setf :expander symbol))) 147 | #+ccl (describe (ccl:setf-function-spec-name `(setf ,symbol)))) 148 | (:type 149 | #+sbcl (describe (sb-kernel:values-specifier-type symbol)) 150 | #+ccl (describe (or (find-class symbol nil) symbol)))))) 151 | -------------------------------------------------------------------------------- /Apps/console/gui/wholine.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-console) 2 | 3 | ;;; parameters 4 | 5 | (defparameter *wholine-text-style* (clim:make-text-style :sans-serif :roman :normal)) 6 | (defparameter *wholine-background* clim:+gray90+) 7 | (defparameter *wholine-padding* 5) 8 | 9 | ;;; Presentation types 10 | (clim:define-presentation-type bytes () :inherit-from 'integer) 11 | 12 | (clim:define-presentation-method clim:present (object (type bytes) 13 | stream (view clim:textual-view) 14 | &key &allow-other-keys) 15 | (if (zerop object) 16 | (princ "0" stream) 17 | (let* ((suffixes '(" bytes" " KB" " MB" " GB" " TB" " PB")) 18 | (x (floor (realpart (log object 1000)))) 19 | (idx (min x (1- (length suffixes))))) 20 | (if (zerop idx) 21 | (format stream "~A bytes" object) 22 | (format stream "~,1F~A" (/ object (expt 1000 idx)) (nth idx suffixes)))))) 23 | 24 | 25 | ;; Wholine Pane 26 | 27 | (defclass wholine-pane (clim:application-pane) 28 | () 29 | (:default-initargs :background *wholine-background* 30 | :display-function #'display-wholine 31 | :scroll-bars nil 32 | :display-time :command-loop 33 | :end-of-line-action :allow)) 34 | 35 | (defmethod clim:compose-space ((pane wholine-pane) &key width height) 36 | (declare (ignore width height)) 37 | (let ((h (+ (* 2 *wholine-padding*) (clim:text-style-height *wholine-text-style* pane)))) 38 | (clim:make-space-requirement :height h 39 | :min-height h 40 | :max-height h))) 41 | 42 | (defun display-wholine (frame stream-pane) 43 | (let ((record (clim:with-output-to-output-record (stream-pane) 44 | (let* ((*standard-output* stream-pane)) 45 | (generate-wholine-contents frame))))) 46 | (clim:with-bounding-rectangle* (rx0 ry0 rx1 ry1) (clim:bounding-rectangle record) 47 | (declare (ignore rx1 ry1)) 48 | (setf (clim:output-record-position record) 49 | (values (+ rx0 *wholine-padding*) (+ ry0 *wholine-padding*)))) 50 | (clim:add-output-record record (clim:stream-output-history stream-pane)) 51 | (clim:replay-output-record record stream-pane))) 52 | 53 | ;;; 54 | ;;; 55 | ;;; 56 | 57 | (defun print-package-name (stream) 58 | (let ((foo (package-name *package*))) 59 | (clim:with-drawing-options (stream :ink clim:+royalblue+) 60 | (format stream "~A" (reduce (lambda (&optional (a foo) (b foo)) 61 | (if (< (length a) (length b)) a b)) 62 | (package-nicknames *package*)))))) 63 | 64 | (defun frob-pathname (pathname) 65 | (namestring (truename pathname))) 66 | 67 | (defun generate-wholine-contents (frame) 68 | (declare (ignore frame)) 69 | (let* ((username (or (osicat:environment-variable "USER") 70 | "luser")) 71 | (sitename (machine-instance)) 72 | (memusage #+(or cmu scl) (lisp::dynamic-usage) 73 | #+sbcl (sb-kernel:dynamic-usage) 74 | #+lispworks (getf (system:room-values) :total-allocated) 75 | #+openmcl (+ (ccl::%usedbytes) (ccl::%freebytes)) 76 | #+clisp (values (sys::%room)) 77 | #-(or cmu scl sbcl lispworks openmcl clisp) 0)) 78 | (clim:with-text-style (t *wholine-text-style*) 79 | (clim:formatting-table (t :x-spacing '(2 :character)) 80 | (clim:formatting-row (t) 81 | (macrolet ((cell ((align-x) &body body) 82 | `(clim:formatting-cell (t :align-x ,align-x) ,@body))) 83 | (cell (:left) (format t "~A@~A" username sitename)) 84 | (cell (:center) 85 | (when (numberp memusage) 86 | (clim:present memusage 'bytes))) 87 | (cell (:center) 88 | (format t "~A threads" (length (bt:all-threads)))) 89 | (cell (:center) 90 | ;; CLISP gives us an error when calling 91 | ;; `cl:probe-file' with a directory argument. 92 | (when #+clisp (or (ignore-errors (ext:probe-directory *default-pathname-defaults*)) 93 | (ignore-errors (probe-file *default-pathname-defaults*))) 94 | #-clisp (probe-file *default-pathname-defaults*) 95 | (clim:with-output-as-presentation (t (truename *default-pathname-defaults*) 'pathname) 96 | (format t "~A" (frob-pathname *default-pathname-defaults*))))) 97 | ;; Although the CLIM spec says the item formatter should try to fill 98 | ;; the available width, I can't get either the item or table formatters 99 | ;; to really do so such that the memory usage appears right justified. 100 | )))))) 101 | 102 | 103 | -------------------------------------------------------------------------------- /Apps/app-manager/gui/frame.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-app-manager) 2 | 3 | (clim:define-application-frame desktop-app-manager () 4 | ((view-option :initform "menu")) 5 | (:menu-bar t) 6 | (:command-table (desktop-app-manager 7 | :inherit-from (deski:edit-application-command-table) 8 | :menu (("Quit" :command com-quit) 9 | ("AppMan" :menu menubar-app-command-table) 10 | ("Application" :menu deski:edit-application-command-table)))) 11 | (:panes 12 | (application-display :application 13 | :height 300 14 | :width 400 15 | :display-function #'%update-application-display 16 | :display-time :command-loop) 17 | (interactor :interactor :display-time :command-loop) 18 | (edit-option 19 | (clim:with-radio-box (:orientation :vertical 20 | :value-changed-callback '%update-edit-option) 21 | (clim:radio-box-current-selection "yes") 22 | "no")) 23 | (view-option 24 | (clim:with-radio-box (:orientation :vertical 25 | :value-changed-callback '%update-view-option) 26 | (clim:radio-box-current-selection "menu") 27 | "all"))) 28 | (:layouts 29 | (default 30 | (clim:vertically () 31 | (2/3 32 | (clim:horizontally nil 33 | (clim:labelling (:label "Applications") 34 | application-display) 35 | (clim:vertically nil 36 | (clim:labelling (:label "View") 37 | view-option) 38 | (clim:labelling (:label "Edit local files") 39 | edit-option) 40 | clim:+fill+))) 41 | (1/3 (clim:labelling (:label "Interactor") 42 | interactor)))))) 43 | 44 | ;; output 45 | 46 | (defmethod clim:frame-standard-output ((frame desktop-app-manager)) 47 | (clim:find-pane-named clim:*application-frame* 'application)) 48 | 49 | ;; initialization 50 | 51 | (defmethod clim:adopt-frame :after (fm (frame desktop-app-manager)) 52 | (declare (ignore fm))) 53 | 54 | (defmethod clim:disown-frame :after (fm (frame desktop-app-manager)) 55 | (declare (ignore fm))) 56 | 57 | ;; commands 58 | 59 | ;; updating 60 | 61 | (defun %update-edit-option (this-gadget selected-gadget) 62 | (declare (ignore this-gadget)) 63 | (setf deski::*force-user-app-files-p* 64 | (string= (clim:gadget-label selected-gadget) "yes"))) 65 | 66 | (defun %update-view-option (this-gadget selected-gadget) 67 | (declare (ignore this-gadget)) 68 | (with-slots (view-option) clim:*application-frame* 69 | (let ((label (clim:gadget-label selected-gadget))) 70 | (cond 71 | ((string= label "menu") 72 | (setf view-option "menu")) 73 | ((string= label "all") 74 | (setf view-option "all"))))) 75 | (clim:redisplay-frame-pane clim:*application-frame* 76 | (clim:find-pane-named clim:*application-frame* 'application-display))) 77 | 78 | (defun %update-application-display (desktop-app-manager stream) 79 | (declare (ignore desktop-app-manager)) 80 | (draw-app-table stream)) 81 | 82 | (clim:define-command-table menubar-app-command-table 83 | :menu (("Clear Interactor" :command (com-clear-interactor)) 84 | ("Refresh" :command (com-refresh)) 85 | ("Refresh Apps" :command (com-refresh-apps)) 86 | ("Quit" :command (com-quit)))) 87 | 88 | 89 | (defun draw-app-table (stream) 90 | (let ((max-width (round 91 | (/ (/ (clim:rectangle-width 92 | (clim:sheet-region stream)) 93 | 2) 94 | (clim:stream-string-width stream #\M))))) 95 | (with-slots (view-option) clim:*application-frame* 96 | (clim:with-drawing-options (stream :text-size :large) 97 | (if (string= view-option "all") 98 | (format stream "~% Registered Apps~%~%") 99 | (format stream "~% Menu Apps~%~%")) 100 | (fresh-line stream)) 101 | (clim:formatting-table (stream :x-spacing '(2 :character)) 102 | (clim:formatting-row (stream) 103 | (clim:with-text-face (stream :italic) 104 | (clim:formatting-cell (stream :align-x :center) (format stream "Name")) 105 | (clim:formatting-cell (stream :align-x :center) (format stream "Prety Name")) 106 | (clim:formatting-cell (stream :align-x :center) (format stream "Menu")) 107 | (clim:formatting-cell (stream :align-x :center) (format stream "I/L/C")) 108 | )) 109 | (dolist (app (deski::registered-applications)) 110 | (when (or (string= view-option "all") (application-menu-p app)) 111 | (clim:with-output-as-presentation (stream app 'application) 112 | (clim:formatting-row (stream) 113 | (clim:formatting-cell (stream :align-x :left :align-y :top) 114 | (princ (application-name app) stream)) 115 | (clim:formatting-cell (stream :align-x :left :align-y :top) 116 | (princ (application-pretty-name app) stream)) 117 | (clim:formatting-cell (stream :align-x :left :align-y :top) 118 | (princ (application-menu-p app) stream)) 119 | (clim:formatting-cell (stream :align-x :left :align-y :top) 120 | (when (typep app 'cl-application) 121 | (format stream "~A/~A/~A" 122 | (application-installed-p app) 123 | (application-loaded-p app) 124 | (application-configured-p app))))))))) 125 | (fresh-line stream)))) 126 | 127 | 128 | 129 | -------------------------------------------------------------------------------- /Core/src/application-mixins.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | ;;;; 4 | ;;;; Application Mixin 5 | ;;;; 6 | 7 | ;;; 8 | ;;; Simple Application Mixin 9 | ;;; 10 | 11 | (defclass simple-application-mixin () 12 | ((entry-fn :initarg :entry-fn 13 | :accessor application-entry-fn 14 | :initform nil))) 15 | 16 | (defmethod run-application ((application simple-application-mixin) &rest args) 17 | (with-slots (entry-fn name) application 18 | (if entry-fn 19 | (apply entry-fn application args) 20 | (progn 21 | (log-error (format nil "Entry function for ~A undefined" name)) 22 | (error "Entry function for ~A undefined" name))))) 23 | 24 | ;;; 25 | ;;; Simple CL Appplication Mixin 26 | ;;; 27 | 28 | (defclass simple-cl-application-mixin (simple-application-mixin) 29 | ()) 30 | 31 | (defmethod load-application ((application simple-cl-application-mixin) &optional force-p) 32 | (declare (ignore force-p)) 33 | (with-slots (name system-name debug-system-p) application 34 | (if system-name 35 | (if debug-system-p 36 | (asdf:operate 'asdf:load-source-op system-name :force-not t) 37 | (asdf:require-system system-name)) 38 | (log-warn (format nil "System name for ~A undefined" name))))) 39 | 40 | (defmethod install-application ((application simple-cl-application-mixin) &optional force-p) 41 | (declare (ignore force-p)) 42 | (with-slots (name system-name git-repo) application 43 | (if system-name 44 | (handler-case 45 | (ql:quickload system-name) 46 | (ql:system-not-found () 47 | (log-warn (format nil "System ~A non found in quicklisp" name)) 48 | (if git-repo 49 | (let ((cur-dir (uiop/os:getcwd))) 50 | (uiop/os:chdir (first ql:*local-project-directories*)) 51 | (uiop/run-program:run-program 52 | (list "git" "clone" git-repo) 53 | :force-shell t :output t :error-output t) 54 | (uiop/os:chdir cur-dir) 55 | (ql:quickload system-name)) 56 | (log-warn (format nil "Git repository for ~A undefined" name))))) 57 | (log-warn (format nil "System name for ~A undefined" name))))) 58 | 59 | ;;; 60 | ;;; Simple Shell Mixin 61 | ;;; 62 | 63 | (defclass simple-shell-application-mixin (simple-application-mixin) 64 | ((make-command-fn :initarg :make-command-fn 65 | :accessor application-make-command-fn 66 | :initform nil)) 67 | (:default-initargs 68 | :entry-fn #'(lambda (application &rest args) 69 | (with-slots (make-command-fn name) application 70 | (if make-command-fn 71 | (uiop:run-program (apply make-command-fn args)) 72 | (progn 73 | (log-error (format nil "Make command function for ~A undefined" name)) 74 | (error "Make command function for ~A undefined" name))))))) 75 | 76 | 77 | ;;;; 78 | ;;;; Standard Application Mixin 79 | ;;;; 80 | 81 | (defclass standard-application-mixin () 82 | ()) 83 | 84 | ;;; protocols 85 | 86 | (defgeneric application-file (application &optional force-p force-user-p)) 87 | (defgeneric application-config-file (application &optional force-p force-user-p)) 88 | (defgeneric application-style-file (application &optional force-p force-user-p force-style)) 89 | 90 | (defgeneric load-application-config-file (application)) 91 | (defgeneric load-application-style-file (application &optional force-style)) 92 | 93 | ;;; protocol: application files 94 | 95 | (defmethod application-file ((application standard-application-mixin) 96 | &optional force-p force-user-p) 97 | (with-slots (name) application 98 | (find-application-file name force-p force-user-p))) 99 | 100 | (defmethod application-config-file ((application standard-application-mixin) 101 | &optional force-p force-user-p) 102 | (with-slots (name) application 103 | (find-config-file name nil force-p force-user-p))) 104 | 105 | (defmethod application-style-file ((application standard-application-mixin) 106 | &optional force-p force-user-p force-style) 107 | (with-slots (name) application 108 | (find-config-file name (or force-style nil) 109 | force-p force-user-p))) 110 | 111 | ;;; protocol: load files 112 | 113 | (defmethod load-application-config-file ((application standard-application-mixin)) 114 | (with-slots (name) application 115 | (let ((config-file (application-config-file application))) 116 | (if config-file 117 | (let ((*application* application)) 118 | (load config-file)) 119 | (log-warn (format nil "Config file (~A) for ~A not found" 120 | (config-file-relative-pathname name) 121 | name)))))) 122 | 123 | (defmethod load-application-style-file ((application standard-application-mixin) 124 | &optional force-style) 125 | (with-slots (name) application 126 | (let ((sty (or force-style))) 127 | (let ((style-file (application-style-file application nil nil sty))) 128 | (if style-file 129 | (let ((*application* application)) 130 | (load style-file)) 131 | (progn 132 | (log-warn (format nil "Style file (~A) for ~A not found" 133 | (config-file-relative-pathname name sty) 134 | name)) 135 | (unless (eq sty :default) 136 | (load-application-style-file application :default)))))))) 137 | 138 | ;;; protocol: configure 139 | 140 | (defmethod configure-application :before ((application standard-application-mixin) 141 | &optional force-p) 142 | (declare (ignore force-p)) 143 | (load-application-config-file application) 144 | (load-application-style-file application)) 145 | 146 | ;;; 147 | ;;; Standard CL Application Mixin 148 | ;;; 149 | 150 | (defclass standard-cl-application-mixin (standard-application-mixin) 151 | ()) 152 | 153 | ;;; 154 | ;;; Debugger Application 155 | ;;; 156 | 157 | (defclass simple-debugger-application-mixin () 158 | ((debugger-fn :initarg :debugger-fn 159 | :accessor application-debugger-fn 160 | :initform nil))) 161 | -------------------------------------------------------------------------------- /Core/src/standard-pathnames.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | 4 | ;;;; 5 | ;;;; Desktop standard pathnames 6 | ;;;; 7 | 8 | ;;; 9 | ;;; user directory 10 | ;;; 11 | 12 | (defparameter *user-directory* (uiop:merge-pathnames* "~/.mcclim-desktop/")) 13 | 14 | (defun find-user-file (relative-pathname &optional error-p) 15 | (let ((pathname (uiop:merge-pathnames* 16 | relative-pathname *user-directory*))) 17 | (or (probe-file pathname) 18 | (and error-p (error "file (~A) not found" pathname))))) 19 | 20 | (defun create-user-file (relative-pathname &optional copy-from-pathname) 21 | (log-warn (format nil "Create file (~A) in the user directory (~A)" 22 | relative-pathname *user-directory*)) 23 | (let ((dest (uiop:merge-pathnames* relative-pathname *user-directory*)) 24 | (source (or 25 | (find-file relative-pathname) 26 | copy-from-pathname))) 27 | (uiop:ensure-all-directories-exist (list dest)) 28 | (when source 29 | (uiop:copy-file source dest)) 30 | dest)) 31 | 32 | (defun find-user-files (relative-directory-pathname &optional error-p) 33 | (let ((pathname (uiop:merge-pathnames* relative-directory-pathname 34 | *user-directory*))) 35 | (when (and (not (probe-file pathname)) error-p) 36 | (error "file (~A) not found" pathname)) 37 | (uiop/filesystem:directory-files pathname))) 38 | 39 | ;;; 40 | ;;; system directories 41 | ;;; 42 | 43 | (defvar *system-directories* nil) 44 | (defparameter *system-directory-relative-pathaname* #p"dot-mcclim-desktop/") 45 | 46 | (defun find-system-file (relative-pathname &optional error-p) 47 | (or (find-if #'probe-file 48 | (mapcar #'(lambda (d) (uiop:merge-pathnames* 49 | relative-pathname d)) 50 | *system-directories*)) 51 | (and error-p (error "file (~A) not found" relative-pathname)))) 52 | 53 | (defun find-system-files (relative-pathname) 54 | (let ((out)) 55 | (dolist (dir *system-directories*) 56 | (let ((pathname (uiop:merge-pathnames* relative-pathname 57 | dir))) 58 | (when (probe-file pathname) 59 | (setf out (append (uiop/filesystem:directory-files pathname) out))))) 60 | out)) 61 | 62 | (defun find-system-directories () 63 | (setf *system-directories* nil) 64 | (dolist (system-name (asdf:registered-systems)) 65 | (multiple-value-bind (foundp found-system pathname previous previous-time) 66 | (asdf:locate-system system-name) 67 | (let ((pathname (asdf:component-pathname previous))) 68 | (when pathname 69 | (let ((p (uiop:merge-pathnames* *system-directory-relative-pathaname* 70 | pathname))) 71 | (when (probe-file p) 72 | (unless (member p *system-directories* :test #'equal) 73 | (push p *system-directories*)))))))) 74 | *system-directories*) 75 | 76 | ;;; 77 | ;;; both 78 | ;;; 79 | 80 | (defun find-file (relative-pathname &optional error-p) 81 | (or (find-user-file relative-pathname) 82 | (find-system-file relative-pathname error-p))) 83 | 84 | ;;; 85 | ;;; application files 86 | ;;; 87 | 88 | 89 | (defparameter *application-directory-relative-pathname* "apps/") 90 | (defparameter *application-file-template-name* "~A.lisp") 91 | (defparameter *sample-file-name* "_%sample_") 92 | 93 | (defun application-file-relative-pathname (name) 94 | (uiop:merge-pathnames* (format nil *application-file-template-name* 95 | (string-downcase name)) 96 | *application-directory-relative-pathname*)) 97 | 98 | (defun find-application-file (name &optional force-p force-user-p) 99 | (let ((rel-pathname (application-file-relative-pathname name))) 100 | (let ((file 101 | (or (find-user-file rel-pathname) 102 | (and (not force-user-p) 103 | (find-system-file rel-pathname))))) 104 | (when (and (not file) force-p) 105 | (setf file (create-user-file 106 | rel-pathname 107 | (or 108 | (find-system-file rel-pathname) 109 | (find-application-file *sample-file-name*))))) 110 | file))) 111 | 112 | (defun find-application-files () 113 | (remove-if #'(lambda (file) 114 | (string= (pathname-name file) *sample-file-name*)) 115 | (append 116 | (find-user-files *application-directory-relative-pathname*) 117 | (find-system-files *application-directory-relative-pathname*)))) 118 | 119 | ;;; 120 | ;;; config files 121 | ;;; 122 | 123 | (defparameter *config-directory-relative-pathname* "config/") 124 | (defparameter *config-file-template-name* "~A-~A.lisp") 125 | 126 | (defun config-file-relative-pathname (name &optional style) 127 | (uiop:merge-pathnames* (format nil *config-file-template-name* 128 | (string-downcase name) 129 | (string-downcase (or style "config"))) 130 | *config-directory-relative-pathname*)) 131 | 132 | (defun find-config-file (name &optional style force-p force-user-p) 133 | (let ((rel-pathname (config-file-relative-pathname name style))) 134 | (let ((file 135 | (or (find-user-file rel-pathname) 136 | (and (not force-user-p) 137 | (find-system-file rel-pathname))))) 138 | (when (and (not file) force-p) 139 | (setf file (create-user-file 140 | rel-pathname 141 | (or 142 | (find-system-file rel-pathname) 143 | (and style 144 | (not (eq style :default)) 145 | (find-config-file name :default nil nil)) 146 | (find-config-file *sample-file-name* (and style :default)))))) 147 | file))) 148 | 149 | ;;; 150 | ;;; 151 | ;;; 152 | 153 | (defparameter *init-file-name* "init.lisp") 154 | (defparameter *config-file-name* "config.lisp") 155 | 156 | (defun ensure-all-user-directories-exist () 157 | (uiop:ensure-all-directories-exist 158 | (list *user-directory* 159 | (uiop:merge-pathnames* 160 | *application-directory-relative-pathname* 161 | *user-directory*) 162 | (uiop:merge-pathnames* 163 | *config-directory-relative-pathname* 164 | *user-directory*)))) 165 | -------------------------------------------------------------------------------- /Resource/src/application.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | ;;; 4 | ;;; Clim resource for applications 5 | ;;; 6 | 7 | (defun application->textual-string (app) 8 | (application-pretty-name app)) 9 | 10 | ;;; presentations 11 | 12 | (clim:define-presentation-method clim:present (app (type application) 13 | stream 14 | (view clim:textual-view) 15 | &key) 16 | (princ (application->textual-string app) stream)) 17 | 18 | (clim:define-presentation-method clim:accept ((type application) stream view &key) 19 | (values 20 | (clim:completing-from-suggestions (stream :partial-completers '(#\Space)) 21 | (mapcar #'(lambda (o) 22 | (clim:suggest (application->textual-string o) o)) 23 | (registered-applications))))) 24 | 25 | ;;; command table 26 | 27 | ;;(defparameter application-command-table nil) 28 | (clim:define-command-table application-command-table) 29 | (clim:define-command-table edit-application-command-table 30 | :inherit-from (application-command-table) 31 | :inherit-menu t) 32 | 33 | ;;; translators 34 | 35 | (clim:define-presentation-translator expression-to-application 36 | (clim:expression application application-command-table 37 | :documentation "expression to application" 38 | :tester ((object) (clim:presentation-typep object 'application)) 39 | :tester-definitive t) 40 | (object) 41 | object) 42 | 43 | (clim:define-presentation-translator application-to-expression 44 | (application clim:expression application-command-table 45 | :documentation "application to expression") 46 | (object) 47 | object) 48 | 49 | ;;; parameters 50 | 51 | (defvar *force-user-app-files-p* t) 52 | 53 | ;;; commands 54 | 55 | (clim:define-command (com-launch-app :command-table application-command-table 56 | :name t 57 | :menu t) 58 | ((app application)) 59 | (launch-application app)) 60 | 61 | (clim:define-command (com-open-app-home-page :command-table application-command-table 62 | :name t 63 | :menu t) 64 | ((app 'application)) 65 | (launch-application (find-application "browser") 66 | :args (list (application-home-page app)))) 67 | 68 | (clim:define-command (com-inspect-app :command-table application-command-table 69 | :name t 70 | :menu t) 71 | ((app 'application)) 72 | (launch-application (find-application "clouseau") 73 | :args (list app))) 74 | 75 | (clim:define-command (com-edit-app-def-file :command-table edit-application-command-table 76 | :menu t 77 | :name t) 78 | ((app 'application)) 79 | (when (application-file app t *force-user-app-files-p*) 80 | (refresh-application (application-name app)) 81 | (edit-file (application-file app) 82 | :cb-fn #'(lambda (&rest rest) 83 | (declare (ignore rest)) 84 | (refresh-application (application-name app)))))) 85 | 86 | (clim:define-command (com-edit-app-config-file :command-table edit-application-command-table 87 | :menu t 88 | :name t) 89 | ((app 'application)) 90 | (when (application-config-file app t *force-user-app-files-p*) 91 | (when (application-configured-p app) 92 | (configure-application app t)) 93 | (edit-file (application-config-file app) 94 | :cb-fn #'(lambda (&rest rest) 95 | (declare (ignore rest)) 96 | (when (application-configured-p app) 97 | (configure-application app t)))))) 98 | 99 | (clim:define-command (com-edit-app-style-file :command-table edit-application-command-table 100 | :name t 101 | :menu t) 102 | ((app 'application)) 103 | (when (application-configured-p app) 104 | (configure-application app t)) 105 | (when (application-style-file app t *force-user-app-files-p*) 106 | (edit-file (application-style-file app) 107 | :cb-fn #'(lambda (&rest rest) 108 | (declare (ignore rest)) 109 | (when (application-configured-p app) 110 | (configure-application app t)))))) 111 | 112 | 113 | (clim:define-command (com-list-apps :command-table application-command-table 114 | :name nil 115 | :menu nil) 116 | () 117 | (dolist (app (registered-applications)) 118 | (fresh-line) 119 | (clim:with-output-as-presentation (t app (deski::desktop-presentation-type-of app) 120 | :allow-sensitive-inferiors nil 121 | :single-box t) 122 | (clim:present app 'clim:expression)))) 123 | 124 | ;; utility 125 | 126 | (defun edit-file (filename &key cb-fn) 127 | (let ((editor (find-application "editor"))) 128 | (launch-application editor :args (list filename) :cb-fn cb-fn))) 129 | 130 | ;;; translators 131 | 132 | (clim:define-presentation-to-command-translator launch-app 133 | (application com-launch-app application-command-table 134 | :gesture :help 135 | :documentation "launch") 136 | (app) 137 | (list app)) 138 | 139 | (clim:define-presentation-to-command-translator inspect-app 140 | (application com-inspect-app application-command-table 141 | :gesture :help 142 | :documentation "inspect") 143 | (app) 144 | (list app)) 145 | 146 | (clim:define-presentation-to-command-translator open-app-home-page 147 | (application com-open-app-home-page application-command-table 148 | :gesture :help 149 | :documentation "open home page") 150 | (app) 151 | (list app)) 152 | 153 | (clim:define-presentation-to-command-translator edit-app-def-file 154 | (application com-edit-app-def-file edit-application-command-table 155 | :gesture :help 156 | :documentation "edit def file") 157 | (app) 158 | (list app)) 159 | 160 | (clim:define-presentation-to-command-translator edit-app-config-file 161 | (application com-edit-app-config-file edit-application-command-table 162 | :gesture :help 163 | :documentation "edit config file") 164 | (app) 165 | (list app)) 166 | 167 | (clim:define-presentation-to-command-translator edit-app-style-file 168 | (application com-edit-app-style-file edit-application-command-table 169 | :gesture :help 170 | :documentation "edit style file") 171 | (app) 172 | (list app)) 173 | 174 | -------------------------------------------------------------------------------- /Apps/launcher/gui/frame.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-launcher) 2 | 3 | (defclass log-display-pane (clim:application-pane) 4 | ()) 5 | 6 | (defmethod clim:note-sheet-grafted ((sheet log-display-pane)) 7 | (setf (logger-stream *logger*) sheet)) 8 | 9 | (defmethod clim:note-sheet-degrafted ((sheet log-display-pane)) 10 | (setf (logger-stream *logger*) *trace-output*)) 11 | 12 | 13 | (clim:define-application-frame desktop-launcher () 14 | ((system-debugger) 15 | (view-option :initform "menu")) 16 | (:menu-bar menubar-command-table) 17 | (:command-table (desktop-launcher 18 | :inherit-from (deski::application-command-table))) 19 | (:panes 20 | (application-display :application 21 | :height 300 22 | :width 50 23 | :display-function #'%update-application-display 24 | :display-after-commands nil) 25 | (interactor :interactor :display-time :command-loop) 26 | (log-display-dummy 27 | (clim:make-clim-stream-pane :name 'log-display :type 'log-display-pane :borders t 28 | :display-time nil)) 29 | (edit-option 30 | (clim:with-radio-box (:orientation :vertical 31 | :value-changed-callback '%update-edit-option) 32 | (clim:radio-box-current-selection "yes") 33 | "no")) 34 | (debugger-option 35 | (clim:with-radio-box (:orientation :vertical 36 | :value-changed-callback '%update-debugger-option) 37 | (clim:radio-box-current-selection "system") 38 | "swank" 39 | "clim" 40 | "desktop")) 41 | (view-option 42 | (clim:with-radio-box (:orientation :vertical 43 | :value-changed-callback '%update-view-option) 44 | (clim:radio-box-current-selection "menu") 45 | "all")) 46 | (clear-action :push-button 47 | :activate-callback #'(lambda (gadget) 48 | (declare (ignore gadget)) 49 | (clim:execute-frame-command 50 | clim:*application-frame* `(com-clear))) 51 | :label "Clear Window")) 52 | (:layouts 53 | (defaults 54 | (clim:vertically () 55 | (2/3 56 | (clim:horizontally nil 57 | (clim:labelling (:label "Applications") 58 | application-display) 59 | (clim:vertically nil 60 | (clim:labelling (:label "View") 61 | view-option) 62 | (clim:labelling (:label "Debugger") 63 | debugger-option) 64 | (clim:labelling (:label "Edit local files") 65 | edit-option) 66 | clim:+fill+ 67 | (clim:labelling (:label "Actions") 68 | clear-action)))) 69 | (1/3 (clim:labelling (:label "Log/Output") 70 | log-display-dummy)))) 71 | (interactor 72 | (clim:vertically () 73 | (2/3 74 | (clim:horizontally nil 75 | (clim:labelling (:label "Applications") 76 | application-display) 77 | (clim:vertically nil 78 | (clim:labelling (:label "View") 79 | view-option) 80 | (clim:labelling (:label "Debugger") 81 | debugger-option) 82 | (clim:labelling (:label "Edit local files") 83 | edit-option) 84 | clim:+fill+))) 85 | (1/3 (clim:labelling (:label "Interactor") 86 | interactor)))))) 87 | 88 | ;; output 89 | 90 | (defmethod clim:frame-standard-output ((frame desktop-launcher)) 91 | (clim:find-pane-named clim:*application-frame* 'application-display)) 92 | 93 | ;; initialization 94 | 95 | (defmethod clim:adopt-frame :after (fm (frame desktop-launcher)) 96 | (declare (ignore fm)) 97 | (with-slots (system-debugger) frame 98 | (setf system-debugger *debugger*)) 99 | (update-applications)) 100 | 101 | (defmethod clim:disown-frame :after (fm (frame desktop-launcher)) 102 | (declare (ignore fm)) 103 | (setf (logger-stream *logger*) *trace-output*) 104 | (with-slots (system-debugger) frame 105 | (use-debugger system-debugger))) 106 | 107 | ;; commands 108 | 109 | (define-desktop-launcher-command (com-set-layout :name nil :menu nil) 110 | ((layout-name 'symbol)) 111 | (with-accessors ((layout clim:frame-current-layout)) clim:*application-frame* 112 | (setf layout layout-name))) 113 | 114 | ;; updating 115 | 116 | (defun %update-edit-option (this-gadget selected-gadget) 117 | (declare (ignore this-gadget)) 118 | (setf deski::*force-user-app-files-p* 119 | (string= (clim:gadget-label selected-gadget) "yes"))) 120 | 121 | (defun %update-debugger-option (this-gadget selected-gadget) 122 | (declare (ignore this-gadget)) 123 | (with-slots (system-debugger) clim:*application-frame* 124 | (let ((label (clim:gadget-label selected-gadget))) 125 | (cond 126 | ((string= label "system") 127 | (use-debugger system-debugger)) 128 | ((string= label "swank") 129 | (use-application-as-debugger "swank-debugger")) 130 | ((string= label "clim") 131 | (use-application-as-debugger "clim-debugger")) 132 | ((string= label "desktop") 133 | (use-application-as-debugger "desktop-debugger")))))) 134 | 135 | (defun %update-view-option (this-gadget selected-gadget) 136 | (declare (ignore this-gadget)) 137 | (with-slots (view-option) clim:*application-frame* 138 | (let ((label (clim:gadget-label selected-gadget))) 139 | (cond 140 | ((string= label "menu") 141 | (setf view-option "menu")) 142 | ((string= label "all") 143 | (setf view-option "all"))))) 144 | (clim:redisplay-frame-pane clim:*application-frame* 145 | (clim:find-pane-named clim:*application-frame* 'application-display))) 146 | 147 | (defun %update-application-display (desktop-launcher stream) 148 | (declare (ignore desktop-launcher)) 149 | (with-slots (view-option) clim:*application-frame* 150 | (dolist (app *applications*) 151 | (if (or (string= view-option "all") (application-menu-p app)) 152 | (progn 153 | (clim:present (find-application app) 'application :stream stream) 154 | (format stream "~%")))))) 155 | 156 | ;;; 157 | ;;; Menu 158 | ;;; 159 | 160 | (clim:make-command-table 'layout-command-table 161 | :errorp nil 162 | :menu '(("Log/Output" :command (com-set-layout defaults)) 163 | ("Interactor" :command (com-set-layout interactor)))) 164 | 165 | (clim:make-command-table 'menubar-command-table 166 | :errorp nil 167 | :menu '(("Quit" :command com-quit) 168 | ("Refresh" :command com-refresh) 169 | ("Layout" :menu layout-command-table))) 170 | 171 | -------------------------------------------------------------------------------- /README.org: -------------------------------------------------------------------------------- 1 | * McClim Desktop 2 | A clim-desktop clone. 3 | 4 | ** Usage 5 | 6 | *** CL 7 | 8 | #+BEGIN_SRC lisp 9 | 10 | (desktop:configure) 11 | 12 | (desktop:launch-application 13 | (desktop:find-application "climacs")) 14 | 15 | (desktop:launch-application 16 | (desktop:find-application "climacs") 17 | :args '("/etc/passwd")) 18 | #+END_SRC 19 | 20 | or 21 | 22 | #+BEGIN_SRC lisp 23 | 24 | (desk:configure) 25 | 26 | (desk:launch-app "ernestine") 27 | 28 | (desk:launch-app :climacs :args '("/etc/passwd")) 29 | 30 | #+END_SRC 31 | 32 | *** GUI 33 | 34 | #+BEGIN_SRC lisp 35 | (desk:launch-app "console") 36 | #+END_SRC 37 | 38 | ** Installation 39 | 40 | Clone the project into local-projects of quicklisp, then 41 | 42 | #+BEGIN_SRC lisp 43 | (ql:quickload :mcclim-desktop) 44 | (desktop:configure) 45 | #+END_SRC 46 | 47 | *** roswell 48 | #+BEGIN_SRC 49 | ros install gas2serra/mcclim-desktop 50 | #+END_SRC 51 | To execute: 52 | #+BEGIN_SRC 53 | mcclim-desktop-no-dump.ros 54 | #+END_SRC 55 | or, using an image file, 56 | #+BEGIN_SRC 57 | dump-mcclim-desktop.ros 58 | mcclim-desktop.ros 59 | #+END_SRC 60 | 61 | ** Applications 62 | - Console 63 | [[file:Apps/console/README.org][link]] 64 | - App manager 65 | [[file:Apps/app-manager/README.org][link]] 66 | - Launcher (deprecated) 67 | [[file:Apps/launcher/README.org][link]] 68 | - Apropos Navigator 69 | [[file:Apps/apropos/README.org][link]] 70 | - Debugger 71 | [[file:Apps/debugger/README.org][link]] 72 | - Task Manager 73 | [[file:Apps/task-manager/README.org][link]] 74 | ** External Applications 75 | The applications are automatically installed using quicklisp or calling the clone command of git. 76 | 77 | | Name | What | Source | Quicklisp | 78 | |-------------------------------+-------------------+-----------------------------------------------------------+-----------| 79 | | beirc | irc | https://github.com/MrNeutron/beirc | Yes | 80 | | clim-chess | chess | https://github.com/stassats/clim-chess | No | 81 | | clim-pkg-doc | package browser | https://github.com/jschatzer/clim-pkg-doc | Yes | 82 | | spectacle | image editor | https://github.com/slyrus/spectacle | No | 83 | | climc | instant messaging | https://github.com/nlamirault/climc | Yes | 84 | | climon | simon game | https://github.com/nlamirault/climon | Yes | 85 | | ernestine | music browser | https://github.com/nlamirault/ernestine | Yes | 86 | | sudoku-mcclim | sudoku | https://github.com/tortkis/sudoku-mcclim | No | 87 | | climacs | editor | https://github.com/robert-strandh/Climacs | Yes | 88 | | gsharp | score editor | https://github.com/informatimago/gsharp | Yes | 89 | | listener | REPL | https://github.com/robert-strandh/McCLIM | Yes | 90 | | class-browser | class browser | https://github.com/pocket7878/clim-class-browser.git | No | 91 | | scigraph | plotting | https://github.com/robert-strandh/McCLIM | Yes | 92 | | mcclide | ide | https://github.com/gas2serra/mcclide | No | 93 | | closure | browser | https://github.com/dym/closure | No | 94 | | panter | mcclim utilities | https://github.com/gas2serra/mcclim-panter | No | 95 | | FTD - The Flexi-Trivial Dired | file manager | https://github.com/gabriel-laddel/flexi-trivial-dired.git | No | 96 | 97 | To add: 98 | 99 | | Name | What | Source | Quicklisp | 100 | |-------------------------------+-------------------------------------------------------------------------------------+-----------------------------------------------------------+-----------| 101 | | icd9it-clim | icd9it - clim treeview with info | https://github.com/jschatzer/icd9it-clim.git | No | 102 | | clim-widgets | small collection of clim widgets | https://github.com/jschatzer/clim-widgets.git | No | 103 | | McPixel | A toy Lisp program for drawing and animating pixel art. | https://github.com/ahefner/McPixel | No | 104 | | tv-series-status | Check the web for the next episodes of TV series and find new episodes at a glance. | https://github.com/OlafMerkert/tv-series-status.git | No | 105 | | raylisp | | https://github.com/nikodemus/raylisp.git | No | 106 | | bibtext | Download bibtex entries for local pdfs from mathscinet. | https://github.com/OlafMerkert/bibtex-manager.git | No | 107 | 108 | ** Utility 109 | *** Clipboard 110 | #+BEGIN_SRC lisp 111 | (desktop-sys:copy-to-x11-clipboard "Hello!") 112 | (desktop-sys:paste-from-x11-clipboard) 113 | #+END_SRC 114 | *** Kill ring 115 | #+BEGIN_SRC lisp 116 | (desktop-sys:copy-to-kill-ring "Hello!") 117 | (desktop-sys:paste-from-kill-ring) 118 | #+END_SRC 119 | *** Screenshot 120 | #+BEGIN_SRC lisp 121 | (desktop-sys:take-x11-screenshot "/tmp/screenshot.png") 122 | #+END_SRC 123 | 124 | 125 | ** Author 126 | 127 | + Alessandro Serra (gas2serra@gmail.com) 128 | 129 | ** Copyright 130 | 131 | Copyright (c) 2016 Alessandro Serra (gas2serra@gmail.com) 132 | 133 | ** License 134 | 135 | Licensed under the GPLv3 License. 136 | -------------------------------------------------------------------------------- /Apps/console/gui/commands.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-console) 2 | 3 | 4 | (define-desktop-console-command (com-quit :menu nil 5 | :name "Quit" 6 | :keystroke (#\q :meta)) 7 | () 8 | (clim:frame-exit clim:*application-frame*)) 9 | 10 | 11 | (define-desktop-console-command (com-clear-output :name "Clear output history" 12 | :command-table application-commands 13 | :provide-output-destination-keyword nil 14 | :keystroke (#\c :meta)) 15 | () 16 | (clim:window-clear *standard-output*)) 17 | 18 | (define-desktop-console-command (com-refresh :menu nil 19 | :name "Refresh Apps" 20 | :keystroke (#\r :meta)) 21 | () 22 | (refresh-applications) 23 | (clim:redisplay-frame-pane clim:*application-frame* 24 | (clim:find-pane-named clim:*application-frame* 25 | 'application-display) 26 | :force-p t) 27 | nil) 28 | 29 | 30 | (clim:define-presentation-to-command-translator launch-app 31 | (application deski::com-launch-app desktop-console 32 | :echo nil 33 | :gesture :select 34 | :documentation "launch" 35 | :tester ((app) (not (application-requires-args-p app)))) 36 | (app) 37 | (list app)) 38 | 39 | 40 | (defvar *use-background-eval* nil) 41 | 42 | (defun shuffle-specials (form values) 43 | (setf +++ ++ 44 | ++ + 45 | + form 46 | /// // 47 | // / 48 | / values 49 | *** ** 50 | ** * 51 | * (first values))) 52 | (defun display-evalues (values) 53 | (labels 54 | ((present-value (value) 55 | (clim:with-output-as-presentation (t value (deski::desktop-presentation-type-of value) 56 | :allow-sensitive-inferiors nil 57 | :single-box t) 58 | (clim:present value 'clim:expression)))) 59 | (clim:with-drawing-options (t :ink clim:+olivedrab+) 60 | (cond ((null values) #+NIL (format t "No values.~%")) 61 | ((= 1 (length values)) 62 | (present-value (first values)) 63 | (fresh-line)) 64 | (t (do* ((i 0 (1+ i)) 65 | (items values (rest items)) 66 | (object (first items) (first items))) 67 | ((null items)) 68 | (clim:with-drawing-options (t :ink clim:+limegreen+) 69 | (clim:with-text-style (t (clim:make-text-style nil :italic :small)) 70 | (format t "~A " i))) 71 | (present-value object) 72 | (fresh-line))))))) 73 | 74 | (define-desktop-console-command (com-eval :menu nil) 75 | ((form 'clim:form :prompt "form")) 76 | (let ((standard-output *standard-output*) 77 | (standard-input *standard-input*) 78 | (debugger-hook *debugger-hook*) 79 | (application-frame clim:*application-frame*)) 80 | (flet ((evaluate () 81 | (let ((- form) 82 | (*standard-output* standard-output) 83 | (*standard-input* standard-input) 84 | (*error-output* standard-output) 85 | (*debugger-hook* debugger-hook) 86 | (clim:*application-frame* application-frame) 87 | error success) 88 | (if *use-background-eval* 89 | (unwind-protect (handler-case (prog1 (cons :values (multiple-value-list (eval form))) 90 | (setf success t)) 91 | (serious-condition (e) 92 | (setf error e) 93 | (error e))) 94 | (when (not success) 95 | (return-from evaluate (cons :error error)))) 96 | (cons :values (multiple-value-list (eval form))))))) 97 | ;; If possible, use a thread for evaluation, permitting us to 98 | ;; interrupt it. 99 | (let ((start-time (get-internal-real-time))) 100 | (destructuring-bind (result . value) 101 | (if (and *use-background-eval* clim-sys:*multiprocessing-p*) 102 | (catch 'done 103 | (let* ((orig-process (clim-sys:current-process)) 104 | (evaluating t) 105 | (eval-process 106 | (clim-sys:make-process 107 | #'(lambda () 108 | (let ((result (evaluate))) 109 | (when evaluating 110 | (clim-sys:process-interrupt orig-process 111 | #'(lambda () 112 | (throw 'done result))))))))) 113 | (unwind-protect 114 | (handler-case (loop for gesture = (clim:read-gesture) 115 | when (and (typep gesture 'clim:keyboard-event) 116 | (eq (clim:keyboard-event-key-name gesture) :pause)) 117 | do (clim-sys:process-interrupt eval-process #'break)) 118 | (clim:abort-gesture () 119 | (clim-sys:destroy-process eval-process) 120 | (cons :abort (/ (- (get-internal-real-time) start-time) 121 | internal-time-units-per-second)))) 122 | (setf evaluating nil)))) 123 | (evaluate)) 124 | (ecase result 125 | (:values 126 | (fresh-line) 127 | (shuffle-specials form value) 128 | (display-evalues value) 129 | (fresh-line)) 130 | (:error (clim:with-text-style (t (clim:make-text-style nil :italic nil)) 131 | (if value 132 | (clim:with-output-as-presentation (t value 'expression) 133 | (format t "Aborted due to ~A: ~A" (type-of value) value)) 134 | (format t "Aborted for unknown reasons (possibly use of ~A)." 'break)))) 135 | (:abort (clim:with-text-style (t (clim:make-text-style nil :italic nil)) 136 | (format t "Aborted by user after ~F seconds." value))))))))) 137 | 138 | 139 | 140 | 141 | #| 142 | (clim:define-presentation-to-command-translator describe-thread 143 | (thread com-describe-thread thread-command-table 144 | :gesture :help 145 | :documentation "describe") 146 | (thread) 147 | (list thread)) 148 | 149 | (clim:define-presentation-to-command-translator show-thread 150 | (thread com-show-thread thread-command-table 151 | :gesture :help 152 | :documentation "show") 153 | (thread) 154 | (list thread)) 155 | 156 | (clim:define-presentation-to-command-translator describe-frame 157 | (clim:application-frame com-describe-frame frame-command-table 158 | :gesture :select 159 | :documentation "describe") 160 | (frame) 161 | (list frame)) 162 | 163 | (clim:define-presentation-to-command-translator show-frame 164 | (clim:application-frame com-show-frame frame-command-table 165 | :gesture :select 166 | :documentation "show") 167 | (frame) 168 | (list frame)) 169 | 170 | |# 171 | -------------------------------------------------------------------------------- /Apps/console/gui/frame.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-console) 2 | 3 | (defclass listener-interactor-pane (clim:interactor-pane) ()) 4 | 5 | (clim:define-application-frame desktop-console () 6 | ((system-debugger)) 7 | (:menu-bar t) 8 | (:command-table (desktop-console 9 | :inherit-from (deski:application-command-table 10 | deski:frame-command-table 11 | deski:thread-command-table) 12 | :menu (("Quit" :command (com-quit)) 13 | ("Console" :menu menubar-console-command-table) 14 | ("Resource" :menu menubar-resource-command-table) 15 | ("Tools" :menu menubar-tool-command-table)))) 16 | (:disabled-commands) 17 | (:panes 18 | (application-display :application 19 | :width 200 20 | :height 300 21 | :display-function #'%update-application-display 22 | :display-time t) 23 | (interactor-container 24 | (clim:make-clim-stream-pane 25 | :type 'listener-interactor-pane 26 | :name 'interactor :scroll-bars t 27 | ;;:default-view +listener-view+ 28 | :width 650 29 | :height 300)) 30 | (doc :pointer-documentation) 31 | (wholine (clim:make-pane 'wholine-pane)) 32 | (debugger-option 33 | (clim:with-radio-box (:orientation :vertical 34 | :value-changed-callback '%update-debugger-option) 35 | (clim:radio-box-current-selection "system") 36 | "swank" 37 | "clim" 38 | "desktop"))) 39 | (:top-level (clim:default-frame-top-level :prompt 'print-listener-prompt)) 40 | (:layouts 41 | (default 42 | (clim:horizontally () 43 | (clim:vertically () 44 | (clim:labelling (:label "Debugger") 45 | debugger-option) 46 | (clim:+fill+ 47 | (clim:labelling (:label "Applications") 48 | application-display))) 49 | (clim:+fill+ 50 | (clim:labelling (:label "Console") 51 | (clim:vertically () 52 | (clim:+fill+ interactor-container) 53 | doc 54 | wholine))))))) 55 | 56 | ;; initialization 57 | 58 | (defmethod clim:adopt-frame :after (fm (frame desktop-console)) 59 | (declare (ignore fm)) 60 | (with-slots (system-debugger) frame 61 | (setf system-debugger *debugger*)) 62 | (in-package :desk-user)) 63 | 64 | (defmethod clim:disown-frame :after (fm (frame desktop-console)) 65 | (declare (ignore fm)) 66 | (with-slots (system-debugger) frame 67 | (use-debugger system-debugger))) 68 | 69 | ;; utility 70 | 71 | (defun print-listener-prompt (stream frame) 72 | (declare (ignore frame)) 73 | (print-package-name stream) 74 | (princ "> " stream)) 75 | 76 | ;; output 77 | 78 | (defmethod clim:frame-standard-output ((frame desktop-console)) 79 | (clim:get-frame-pane frame 'interactor)) 80 | 81 | ;; read command 82 | 83 | (clim:define-presentation-type empty-input ()) 84 | 85 | (clim:define-presentation-method clim:present 86 | (object (type empty-input) stream view &key &allow-other-keys) 87 | (princ "" stream)) 88 | 89 | 90 | (defun compute-inherited-keystrokes (command-table) 91 | "Return a list containing the keyboard gestures of accelerators defined in 92 | 'command-table' and all tables it inherits from." 93 | (let (accumulated-keystrokes) 94 | (climi::do-command-table-inheritance (comtab command-table) 95 | (climi::with-command-table-keystrokes (keystrokes comtab) 96 | (dolist (keystroke keystrokes) 97 | (setf accumulated-keystrokes (adjoin keystroke accumulated-keystrokes :test #'equal))))) 98 | accumulated-keystrokes)) 99 | 100 | 101 | (defmethod clim:read-frame-command ((frame desktop-console) &key (stream *standard-input*)) 102 | "Specialized for the listener, read a lisp form to eval, or a command." 103 | (multiple-value-bind (object type) 104 | (let* ((clim:*command-dispatchers* '(#\,)) 105 | (command-table (clim:frame-command-table frame)) 106 | (clim:*accelerator-gestures* (compute-inherited-keystrokes command-table))) 107 | (handler-case 108 | (clim:with-text-style (stream (clim:make-text-style :fix :roman :normal)) 109 | (clim:accept 'clim:command-or-form :stream stream :prompt nil 110 | :default "hello" :default-type 'empty-input)) 111 | (clim:accelerator-gesture (c) 112 | (let ((command 113 | (clim:lookup-keystroke-command-item (clim:accelerator-gesture-event c) 114 | command-table))) 115 | (if (and (listp command) 116 | (clim:partial-command-p command)) 117 | (funcall clim:*partial-command-parser* 118 | command-table stream command 119 | (position clim:*unsupplied-argument-marker* command)) 120 | (values command 'clim:command)))))) 121 | (cond 122 | ((clim:presentation-subtypep type 'empty-input) 123 | ;; Do nothing. 124 | `(com-eval (values))) 125 | ((clim:presentation-subtypep type 'command) object) 126 | (t `(com-eval ,object))))) 127 | 128 | ;; updating 129 | 130 | (defun %update-debugger-option (this-gadget selected-gadget) 131 | (declare (ignore this-gadget)) 132 | (with-slots (system-debugger) clim:*application-frame* 133 | (let ((label (clim:gadget-label selected-gadget))) 134 | (cond 135 | ((string= label "system") 136 | (use-debugger system-debugger)) 137 | ((string= label "swank") 138 | (use-application-as-debugger "swank-debugger")) 139 | ((string= label "clim") 140 | (use-application-as-debugger "clim-debugger")) 141 | ((string= label "desktop") 142 | (use-application-as-debugger "desktop-debugger")))))) 143 | 144 | (defun %update-application-display (desktop-console stream) 145 | (declare (ignore desktop-console)) 146 | (dolist (app (sort (registered-applications) #'string< :key #'application-pretty-name)) 147 | (when (application-menu-p app) 148 | (fresh-line stream) 149 | (clim:present app 150 | 'application 151 | :view clim:+textual-view+ 152 | :stream stream))) 153 | (fresh-line stream)) 154 | 155 | ;;; 156 | ;;; Menu 157 | ;;; 158 | 159 | (clim:define-command-table menubar-console-command-table 160 | :menu (("Clear Output" :command (com-clear-output)) 161 | ("Refresh apps" :command (com-refresh)) 162 | ("Quit" :command (com-quit)))) 163 | 164 | (clim:define-command-table menubar-resource-command-table 165 | :menu (("Thread" :menu deski:thread-command-table) 166 | ("Frame" :menu deski:frame-command-table) 167 | ("Application" :menu deski:application-command-table))) 168 | 169 | (clim:add-command-to-command-table 'deski::com-list-threads 'menubar-resource-command-table 170 | :name t 171 | :menu t 172 | :errorp nil) 173 | 174 | (clim:add-command-to-command-table 'deski::com-list-frames 'menubar-resource-command-table 175 | :name t 176 | :menu t 177 | :errorp nil) 178 | 179 | (clim:add-command-to-command-table 'deski::com-list-apps 'menubar-resource-command-table 180 | :name t 181 | :menu t 182 | :errorp nil) 183 | 184 | (clim:define-command-table menubar-tool-command-table) 185 | 186 | (clim:add-menu-item-to-command-table 'menubar-tool-command-table 187 | "App Manager" 188 | :command `(deski::com-launch-app ,(find-application "app-manager")) :errorp nil) 189 | 190 | (clim:add-menu-item-to-command-table 'menubar-tool-command-table 191 | "Task Manager" 192 | :command `(deski::com-launch-app ,(find-application "task-manager")) :errorp nil) 193 | 194 | -------------------------------------------------------------------------------- /Apps/apropos/src/iapropos.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-apropos) 2 | 3 | ;;; 4 | ;;; parameters 5 | ;;; 6 | 7 | (defparameter *default-iapropos-max-result-length* 1000 8 | "The max length of the result") 9 | 10 | ;;; 11 | ;;; interactive apropos 12 | ;;; 13 | 14 | (defclass iapropos () 15 | ((symbol-text :initform nil 16 | :accessor iapropos-symbol-text) 17 | (cached-symbol-scanner :initform nil) 18 | (package-text :initform "" 19 | :accessor iapropos-package-text) 20 | (cached-package-scanner :initform nil) 21 | (external-yes/no :type '(member nil :yes :no) 22 | :initform nil 23 | :accessor iapropos-external-yes/no) 24 | (documentation-yes/no :type '(member nil :yes :no) 25 | :initform nil 26 | :accessor iapropos-documentation-yes/no) 27 | (bound-to :type '(member nil 28 | :variable :function :generic-function 29 | :class :macro 30 | :setf :type) 31 | :initform nil 32 | :accessor iapropos-bound-to) 33 | (subclass-of :initform nil 34 | :accessor iapropos-subclass-of) 35 | (metaclass-of :initform nil 36 | :accessor iapropos-metaclass-of) 37 | (filter-fn :initform nil 38 | :accessor iapropos-filter-fn) 39 | (max-result-length :initform *default-iapropos-max-result-length* 40 | :accessor iapropos-max-result-length) 41 | (result-overflow-p :initform nil 42 | :reader iapropos-result-overflow-p) 43 | (cached-matching-packages :initform (list-all-packages)) 44 | (cached-matching-symbols :initform nil)) 45 | (:documentation "Interactive apropos class based on cl-ppcre and swank")) 46 | 47 | ;;; generic funtions 48 | (defgeneric iapropos-matching-symbols (iapropos) 49 | (:documentation "Return the list of symbols that match the specified criteria")) 50 | (defgeneric iapropos-matching-packages (iapropos) 51 | (:documentation "Return the list of packages that match the specified criteria")) 52 | (defgeneric iapropos-matching-symbol-p (iapropos symbol)) 53 | 54 | ;;; methods 55 | (defmethod (setf iapropos-symbol-text) :after (text (iapropos iapropos)) 56 | (declare (ignore text)) 57 | (with-slots (symbol-text cached-symbol-scanner 58 | cached-matching-symbols) iapropos 59 | (handler-bind ((cl-ppcre:ppcre-syntax-error 60 | #'(lambda (condition) 61 | (setf cached-symbol-scanner nil) 62 | (setf cached-matching-symbols nil)))) 63 | (setf cached-symbol-scanner (when (and symbol-text (string/= symbol-text "")) 64 | (cl-ppcre:create-scanner 65 | symbol-text :case-insensitive-mode t))) 66 | (%iapropos-update-matching-symbols iapropos)))) 67 | 68 | (defmethod (setf iapropos-package-text) :after (text (iapropos iapropos)) 69 | (declare (ignore text)) 70 | (with-slots (package-text cached-package-scanner 71 | cached-matching-symbols 72 | cached-matching-packages) iapropos 73 | (handler-bind ((cl-ppcre:ppcre-syntax-error 74 | #'(lambda (condition) 75 | (setf cached-package-scanner nil) 76 | (setf cached-matching-packages nil) 77 | (setf cached-matching-symbols nil)))) 78 | (setf cached-package-scanner (when (and package-text (string/= package-text "")) 79 | (cl-ppcre:create-scanner 80 | package-text :case-insensitive-mode t))) 81 | (%iapropos-update-matching-packages iapropos)))) 82 | 83 | (defmethod (setf iapropos-external-yes/no) :after (val (iapropos iapropos)) 84 | (declare (ignore val)) 85 | (%iapropos-update-matching-symbols iapropos)) 86 | 87 | (defmethod (setf iapropos-bound-to) :after (val (iapropos iapropos)) 88 | (declare (ignore val)) 89 | (%iapropos-update-matching-symbols iapropos)) 90 | 91 | (defmethod (setf iapropos-documentation-yes/no) :after (val (iapropos iapropos)) 92 | (declare (ignore val)) 93 | (%iapropos-update-matching-symbols iapropos)) 94 | 95 | (defmethod (setf iapropos-subclass-of) :after (val (iapropos iapropos)) 96 | (declare (ignore val)) 97 | (%iapropos-update-matching-symbols iapropos)) 98 | 99 | (defmethod (setf iapropos-metaclass-of) :after (val (iapropos iapropos)) 100 | (declare (ignore val)) 101 | (%iapropos-update-matching-symbols iapropos)) 102 | 103 | (defmethod (setf iapropos-filter-fn) :after (val (iapropos iapropos)) 104 | (declare (ignore val)) 105 | (%iapropos-update-matching-symbols iapropos)) 106 | 107 | (defmethod iapropos-matching-packages ((iapropos iapropos)) 108 | (with-slots (cached-matching-packages) iapropos 109 | cached-matching-packages)) 110 | 111 | (defmethod iapropos-matching-symbols ((iapropos iapropos)) 112 | (with-slots (cached-matching-symbols) iapropos 113 | cached-matching-symbols)) 114 | 115 | (defmethod iapropos-matching-symbol-p ((iapropos iapropos) symbol) 116 | (%iapropos-matching-symbol-p iapropos symbol)) 117 | 118 | ;;; 119 | ;;; private generic functions 120 | ;;; 121 | 122 | (defgeneric %iapropos-update-matching-symbols (iapropos)) 123 | (defgeneric %iapropos-update-matching-packages (iapropos)) 124 | 125 | ;;; methods 126 | (defmethod %iapropos-update-matching-packages ((iapropos iapropos)) 127 | (with-slots (cached-matching-packages cached-package-scanner) iapropos 128 | (setf cached-matching-packages 129 | (sort 130 | (if (null cached-package-scanner) 131 | (list-all-packages) 132 | (let ((out)) 133 | (dolist (p (list-all-packages)) 134 | (when (cl-ppcre:scan cached-package-scanner (package-name p)) 135 | (push p out))) 136 | out)) 137 | #'string< :key #'package-name))) 138 | (%iapropos-update-matching-symbols iapropos)) 139 | 140 | (defmethod %iapropos-update-matching-symbols ((iapropos iapropos)) 141 | (with-slots (cached-matching-packages 142 | cached-matching-symbols 143 | max-result-length 144 | result-overflow-p) iapropos 145 | (setf cached-matching-symbols 146 | (let ((swank::*buffer-package* (find-package :common-lisp-user)) 147 | (swank::*buffer-readtable* *readtable*) 148 | (out) 149 | (i 0)) 150 | (setf result-overflow-p nil) 151 | (block iter 152 | (with-package-iterator (next cached-matching-packages :external :internal) 153 | (loop (multiple-value-bind (morep symbol) (next) 154 | (when (not morep) 155 | (return-from iter)) 156 | (when (= i max-result-length) 157 | (setf out (remove-duplicates out)) 158 | (setf i (length out)) 159 | (when (= i max-result-length) 160 | (setf result-overflow-p t) 161 | (return-from iter))) 162 | (when (%iapropos-matching-symbol-p iapropos symbol) 163 | (push symbol out) 164 | (incf i)))))) 165 | (sort 166 | (remove-duplicates out) 167 | #'swank::present-symbol-before-p))))) 168 | 169 | ;;; 170 | ;;; private functions 171 | ;;; 172 | 173 | (defun %iapropos-matching-symbol-p (iapropos symbol) 174 | (with-slots (cached-symbol-scanner external-yes/no documentation-yes/no bound-to 175 | subclass-of metaclass-of filter-fn) iapropos 176 | (and 177 | (if external-yes/no 178 | (eq (not (symbol-external-p symbol)) 179 | (eq external-yes/no :no)) 180 | t) 181 | (if bound-to 182 | (symbol-bound-to symbol bound-to) 183 | t) 184 | (if (eq bound-to :class) 185 | (and 186 | (if subclass-of 187 | (subtypep symbol subclass-of) 188 | t) 189 | (if metaclass-of 190 | (subtypep (type-of (find-class symbol)) metaclass-of) 191 | t)) 192 | t) 193 | (if filter-fn 194 | (funcall filter-fn symbol) 195 | t) 196 | (if (and bound-to documentation-yes/no) 197 | (eq (not (symbol-documentation symbol bound-to)) 198 | (eq documentation-yes/no :no)) 199 | t) 200 | (if cached-symbol-scanner 201 | (cl-ppcre:scan cached-symbol-scanner (symbol-name symbol)) 202 | t)))) 203 | -------------------------------------------------------------------------------- /Core/src/application.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-internals) 2 | 3 | ;;;; 4 | ;;;; Global Variables 5 | ;;;; 6 | 7 | (defvar *application* nil 8 | "The current application") 9 | 10 | ;;;; 11 | ;;;; Application Classes 12 | ;;;; 13 | 14 | ;;; 15 | ;;; Application 16 | ;;; 17 | 18 | (defclass application () 19 | ((name :initarg :name 20 | :reader application-name) 21 | (pretty-name :initarg :pretty-name 22 | :accessor application-pretty-name 23 | :initform nil) 24 | (icon :initarg :icon 25 | :accessor application-icon 26 | :initform nil) 27 | (menu-p :initarg :menu-p 28 | :initform t 29 | :accessor application-menu-p) 30 | (requires-args-p :initarg :requires-args-p 31 | :initform nil 32 | :accessor application-requires-args-p) 33 | (configured-p :reader application-configured-p 34 | :initform nil))) 35 | 36 | ;;; 37 | ;;; Application protocols 38 | ;;; 39 | 40 | (defgeneric run-application (application &rest args)) 41 | (defgeneric launch-application (application &key args cb-fn)) 42 | (defgeneric note-application-start-running (application &rest args)) 43 | (defgeneric note-application-end-running (application &rest args)) 44 | 45 | (defgeneric configure-application (application &optional force-p)) 46 | (defgeneric ensure-application-configured (application)) 47 | (defgeneric need-reconfigure-application (application)) 48 | (defgeneric note-application-configured (application)) 49 | 50 | ;;; protocol: launch/running 51 | 52 | (defmethod launch-application ((application application) &key args cb-fn) 53 | (with-slots (name) application 54 | (bt:make-thread 55 | #'(lambda () 56 | (unwind-protect 57 | (let ((res (apply #'run-application application args))) 58 | (when cb-fn 59 | (funcall cb-fn res application args))))) 60 | :name name))) 61 | 62 | (defmethod run-application :around ((application application) &rest args) 63 | (ensure-application-configured application) 64 | (note-application-start-running application args) 65 | (unwind-protect 66 | (call-next-method) 67 | (note-application-end-running application args))) 68 | 69 | (defmethod note-application-start-running ((application application) &rest args) 70 | (declare (ignore args)) 71 | (with-slots (name) application 72 | (log-info (format nil "Start running ~A application" name)))) 73 | 74 | (defmethod note-application-end-running ((application application) &rest args) 75 | (declare (ignore args)) 76 | (with-slots (name) application 77 | (log-info (format nil "End runnig ~A application" name)))) 78 | 79 | ;;; protocol: configure 80 | 81 | (defmethod configure-application ((application application) &optional (force-p nil)) 82 | (declare (ignore application force-p))) 83 | 84 | (defmethod configure-application :around ((application application) &optional (force-p nil)) 85 | (with-slots (configured-p) application 86 | (when (or force-p (not configured-p)) 87 | (call-next-method) 88 | (setf configured-p t) 89 | (note-application-configured application)))) 90 | 91 | (defmethod ensure-application-configured ((application application)) 92 | (with-slots (configured-p) application 93 | (when (not configured-p) 94 | (configure-application application)))) 95 | 96 | (defmethod need-reconfigure-application ((application application)) 97 | (with-slots (configured-p) application 98 | (setf configured-p nil))) 99 | 100 | (defmethod note-application-configured ((application application)) 101 | (with-slots (name) application 102 | (log-info (format nil "Configured ~A application" name)))) 103 | 104 | ;;; initialize 105 | 106 | (defmethod initialize-instance :after ((application application) &rest initargs) 107 | (declare (ignore initargs)) 108 | (with-slots (name pretty-name) application 109 | (unless pretty-name 110 | (setf pretty-name name)))) 111 | 112 | ;;; print-object 113 | 114 | (defmethod print-object ((obj application) stream) 115 | (print-unreadable-object (obj stream :type t :identity t) 116 | (princ (application-name obj) stream))) 117 | 118 | ;;; 119 | ;;; CL Application 120 | ;;; 121 | 122 | (defclass cl-application (application) 123 | ((home-page :initarg :home-page 124 | :accessor application-home-page 125 | :initform nil) 126 | (git-repo :initarg :git-repo 127 | :accessor application-git-repo 128 | :initform nil) 129 | (system-name :initarg :system-name 130 | :accessor application-system-name 131 | :initform nil) 132 | (debug-system-p :initarg :debug-system-p 133 | :accessor application-debug-system-p 134 | :initform nil) 135 | (loaded-p :reader application-loaded-p 136 | :initform nil) 137 | (installed-p :reader application-installed-p 138 | :initform nil))) 139 | 140 | ;;; 141 | ;;; protocols 142 | ;;; 143 | 144 | (defgeneric load-application (application &optional force-p)) 145 | (defgeneric ensure-application-loaded (application)) 146 | (defgeneric need-reload-application (application)) 147 | (defgeneric note-application-loaded (application)) 148 | 149 | (defgeneric install-application (application &optional force-p)) 150 | (defgeneric ensure-application-installed (application)) 151 | (defgeneric need-reinstall-application (application)) 152 | (defgeneric note-application-installed (application)) 153 | 154 | ;;; protocol: running 155 | 156 | (defmethod run-application :around ((application cl-application) &rest args) 157 | (declare (ignore args)) 158 | (swank/backend:call-with-debugger-hook 159 | #'debugger-hook 160 | (lambda () 161 | (call-next-method)))) 162 | 163 | ;;; protocol: config 164 | 165 | (defmethod configure-application :around ((application cl-application) &optional (force-p nil)) 166 | (declare (ignore force-p)) 167 | (ensure-application-loaded application) 168 | (call-next-method)) 169 | 170 | ;;; protocol: loading 171 | 172 | (defmethod load-application :around ((application cl-application) &optional (force-p nil)) 173 | (ensure-application-installed application) 174 | (with-slots (loaded-p) application 175 | (when (or force-p (not loaded-p)) 176 | (call-next-method) 177 | (setf loaded-p t) 178 | (need-reconfigure-application application) 179 | (note-application-loaded application)))) 180 | 181 | (defmethod ensure-application-loaded ((application cl-application)) 182 | (with-slots (loaded-p) application 183 | (when (not loaded-p) 184 | (load-application application)))) 185 | 186 | (defmethod need-reload-application ((application cl-application)) 187 | (with-slots (loaded-p) application 188 | (setf loaded-p nil)) 189 | (need-reconfigure-application application)) 190 | 191 | (defmethod note-application-loaded ((application cl-application)) 192 | (with-slots (name) application 193 | (log-info (format nil "Loaded ~A application" name)))) 194 | 195 | ;;; protocol: installing 196 | 197 | (defmethod install-application :around ((application cl-application) &optional (force-p nil)) 198 | (with-slots (installed-p system-name) application 199 | (when (or force-p (not installed-p)) 200 | (unless (asdf:find-system system-name nil) 201 | (call-next-method)) 202 | (setf installed-p t) 203 | (need-reload-application application) 204 | (note-application-installed application)))) 205 | 206 | (defmethod ensure-application-installed ((application cl-application)) 207 | (with-slots (installed-p) application 208 | (when (not installed-p) 209 | (install-application application)))) 210 | 211 | (defmethod need-reinstall-application ((application cl-application)) 212 | (with-slots (installed-p) application 213 | (setf installed-p nil)) 214 | (need-reload-application application)) 215 | 216 | (defmethod note-application-installed ((application cl-application)) 217 | (with-slots (name) application 218 | (log-info (format nil "Installed ~A application" name)))) 219 | 220 | ;;; 221 | ;;; McClim Application 222 | ;;; 223 | 224 | (defclass mcclim-application (cl-application) 225 | ((frame-class :initarg :frame-class 226 | :accessor application-frame-class 227 | :initform nil))) 228 | 229 | ;;; 230 | ;;; Link/Alias/Proxy Applications 231 | ;;; 232 | 233 | (defclass link-application (application) 234 | ((reference :initarg :reference 235 | :initform nil 236 | :accessor application-link-reference))) 237 | 238 | (defclass alias-application (link-application) 239 | ()) 240 | 241 | (defmethod launch-application ((application alias-application) &key args cb-fn) 242 | (with-slots (reference) application 243 | (funcall #'launch-application reference :args args :cb-fn cb-fn))) 244 | 245 | (defmethod run-application ((application alias-application) &rest args) 246 | (with-slots (reference) application 247 | (apply #'run-application reference args))) 248 | 249 | (defmethod configure-application ((application alias-application) &optional force-p) 250 | (with-slots (reference) application 251 | (configure-application reference force-p))) 252 | 253 | (defclass proxy-application (link-application) 254 | ()) 255 | 256 | ;;; 257 | ;;; Shell Application 258 | ;;; 259 | 260 | (defclass shell-application (application) 261 | ()) 262 | -------------------------------------------------------------------------------- /Apps/task-manager/gui/frame.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-task-manager) 2 | 3 | (defparameter history-size 100) 4 | 5 | (clim:define-application-frame task-manager (clim:standard-application-frame) 6 | ((timer) 7 | (thread-num-history :initform (make-array history-size)) 8 | (memory-usage-history :initform (make-array history-size)) 9 | (history-position :initform 0)) 10 | (:panes 11 | (thread-display :application 12 | :display-function #'%render-thread-display 13 | :display-time nil) 14 | (history-display-container (clim:make-clim-stream-pane :name 'history-display 15 | ;;:record nil 16 | ;;draw t 17 | :scroll-bars :vertical 18 | :display-function #'%render-history-display 19 | :display-time nil)) 20 | (doc :pointer-documentation) 21 | (interact :interactor)) 22 | (:command-table 23 | (task-manager :inherit-from (deski::frame-command-table 24 | deski::thread-command-table) 25 | :menu (("Quit" :command (com-quit)) 26 | ("TaskMan" :menu menubar-task-command-table) 27 | ("Thread" :menu deski::thread-command-table) 28 | ("Frame" :menu deski::frame-command-table)))) 29 | (:menu-bar t) 30 | (:layouts (default 31 | (clim:vertically () 32 | (1/4 33 | (clim:horizontally nil 34 | (clim:labelling (:label "History") 35 | history-display-container))) 36 | (2/4 37 | (clim:horizontally nil 38 | (clim:labelling (:label "Threads") 39 | thread-display))) 40 | (1/4 41 | (clim:labelling (:label "Interactor") 42 | interact)) 43 | doc)))) 44 | 45 | ;; initialization 46 | 47 | (defmethod clim:adopt-frame :after (fm (frame task-manager)) 48 | (declare (ignore fm)) 49 | (with-slots (timer) frame 50 | (setf timer (trivial-timers:make-timer 51 | #'(lambda () 52 | (clim:execute-frame-command frame '(com-refresh))))))) 53 | 54 | (defmethod clim:disown-frame :after (fm (frame task-manager)) 55 | (declare (ignore fm)) 56 | (with-slots (timer) frame 57 | (when (trivial-timers:timer-scheduled-p timer) 58 | (trivial-timers:unschedule-timer timer)))) 59 | 60 | ;;; 61 | ;;; 62 | ;;; 63 | 64 | (defmethod clim:read-frame-command :around ((frame task-manager) &key &allow-other-keys) 65 | (with-slots (timer) frame 66 | (unwind-protect 67 | (progn 68 | (trivial-timers:schedule-timer timer 3.0 :repeat-interval 3.0) 69 | (call-next-method)) 70 | (trivial-timers:unschedule-timer timer)))) 71 | 72 | ;;; 73 | ;;; render functions 74 | ;; 75 | 76 | (defparameter memory-usage-ink clim:+dark-green+) 77 | (defparameter thread-num-ink clim:+dark-orange+) 78 | 79 | (defun %render-thread-display (frame stream) 80 | (declare (ignore frame)) 81 | (draw-thread-table stream) 82 | (fresh-line stream)) 83 | 84 | (defun %render-history-display (frame stream) 85 | (declare (ignore frame)) 86 | 87 | (with-slots (thread-num-history) 88 | clim:*application-frame* 89 | (when thread-num-history 90 | (fresh-line stream) 91 | (draw-history stream) 92 | (format stream "~%") 93 | (draw-summary stream)))) 94 | 95 | (defun draw-summary (stream) 96 | (with-slots (thread-num-history memory-usage-history history-position) 97 | clim:*application-frame* 98 | (when thread-num-history 99 | (fresh-line stream) 100 | (clim:with-drawing-options (stream :ink memory-usage-ink) 101 | (format stream " Memory usage: ~A " (bytes-to-string (elt memory-usage-history (mod (1- history-position) history-size))))) 102 | (clim:with-drawing-options (stream :ink thread-num-ink) 103 | (format stream "Number of threads: ~A " (elt thread-num-history (mod (1- history-position) history-size)))) 104 | (clim:with-drawing-options (stream) 105 | ;;(format stream "History length: ~A~%" (length thread-num-history))) 106 | ) 107 | (fresh-line stream))) 108 | (clim:stream-force-output stream)) 109 | 110 | (defun draw-history (stream) 111 | (with-slots (thread-num-history memory-usage-history history-position) 112 | clim:*application-frame* 113 | (let* ((padding 10) 114 | (width (- (clim:rectangle-width 115 | (clim:sheet-region stream)) 116 | (* 2 padding))) 117 | (height (- (clim:rectangle-height 118 | (clim:sheet-region stream)) 119 | (* 2 padding) 120 | 20))) 121 | (clim:with-room-for-graphics (stream :first-quadrant nil) 122 | (clim:draw-rectangle* stream padding padding (+ width padding) (+ height padding) :ink clim:+grey70+) 123 | (draw-history-data stream width height padding thread-num-history history-position thread-num-ink) 124 | (draw-history-data stream width height padding memory-usage-history history-position memory-usage-ink)))) 125 | (clim:stream-force-output stream)) 126 | 127 | (defun draw-history-data (stream width height padding data pos ink) 128 | (let ((N history-size) 129 | (max-val (max 1 (reduce #'max data)))) 130 | (let ((dx (/ width N)) 131 | (dy (/ height max-val)) 132 | (x padding) 133 | (old-v (elt data pos)) 134 | (v 0)) 135 | (loop for i from pos to (1- history-size) 136 | do 137 | (setf v (elt data i)) 138 | (clim:draw-line* stream 139 | x (+ padding (- height (* old-v dy))) 140 | (+ x dx) (+ padding (- height (* v dy))) 141 | :line-thickness 2 142 | :ink ink) 143 | (setf old-v v) 144 | (setf x (+ x dx))) 145 | (loop for i from 0 to (1- pos) 146 | do 147 | (setf v (elt data i)) 148 | (clim:draw-line* stream 149 | x (+ padding (- height (* old-v dy))) 150 | (+ x dx) (+ padding (- height (* v dy))) 151 | :line-thickness 2 152 | :ink ink) 153 | (setf old-v v) 154 | (setf x (+ x dx)))))) 155 | 156 | 157 | 158 | (defun draw-thread-table (stream) 159 | (let ((max-width (round 160 | (/ (/ (clim:rectangle-width 161 | (clim:sheet-region stream)) 162 | 2) 163 | (clim:stream-string-width stream #\M))))) 164 | (clim:with-drawing-options (stream :text-size :large) 165 | (format stream " Running frames~%~%") 166 | (fresh-line stream)) 167 | (clim:formatting-table (stream :x-spacing '(2 :character)) 168 | (clim:formatting-row (stream) 169 | (clim:with-text-face (stream :italic) 170 | (clim:formatting-cell (stream :align-x :center) (format stream "Thread")) 171 | (clim:formatting-cell (stream :align-x :center) (format stream "Frames")) 172 | (clim:formatting-cell (stream :align-x :center) (format stream "Frame Position")))) 173 | (dolist (thread (bt:all-threads)) 174 | (clim:formatting-row (stream) 175 | (clim:formatting-cell (stream :align-x :left :align-y :top) 176 | (clim:with-output-as-presentation (stream thread 'deski::thread) 177 | (let ((str (clim:present-to-string thread 'deski::thread 178 | :view clim:+textual-view+))) 179 | (if (> (length str) max-width) 180 | (princ (subseq str 0 max-width) stream) 181 | (princ str stream))))) 182 | (clim:formatting-cell (stream :align-x :left :align-y :top) 183 | (dolist (frame (deski::thread-frames thread)) 184 | (fresh-line stream) 185 | (clim:present frame 'deski::frame 186 | :view clim:+textual-view+ 187 | :stream stream))) 188 | (clim:formatting-cell (stream :align-x :center) 189 | (dolist (frame (deski::thread-frames thread)) 190 | (fresh-line stream) 191 | (draw-small-frame-window stream frame)))))) 192 | (fresh-line stream) 193 | (clim:with-drawing-options (stream :text-size :large) 194 | (format stream " Sleeping frames~%~%") 195 | (fresh-line stream)) 196 | (when (deski::thread-frames nil) 197 | (clim:formatting-table (stream :x-spacing '(2 :character)) 198 | (clim:formatting-row (stream) 199 | (clim:with-text-face (stream :italic) 200 | (clim:formatting-cell (stream :align-x :center :min-width 100) (format stream "Frames")))) 201 | (dolist (frame (deski::thread-frames nil)) 202 | (clim:formatting-row (stream) 203 | (clim:formatting-cell (stream :align-x :left :align-y :top) 204 | (clim:present frame 'deski::frame 205 | :view clim:+textual-view+ 206 | :stream stream)))))))) 207 | 208 | 209 | (defun draw-small-frame-window (stream frame) 210 | (let* ((sc (/ (* 1.9 (clim:stream-string-width stream #\M)) 211 | (clim:rectangle-width 212 | (clim:sheet-region (clim:graft stream))))) 213 | (scaling (clim:make-scaling-transformation sc sc))) 214 | (clim:with-room-for-graphics (stream :first-quadrant nil) 215 | (clim:with-bounding-rectangle* (min-x min-y max-x max-y) 216 | (clim:transform-region scaling 217 | (clim:sheet-region (clim:graft stream))) 218 | (clim:draw-rectangle* stream min-x min-y max-x max-y :filled nil)) 219 | (clim:with-bounding-rectangle* (min-x min-y max-x max-y) 220 | (clim:transform-region scaling 221 | (clim:transform-region (clim:sheet-transformation 222 | (clim:frame-top-level-sheet frame)) 223 | (clim:sheet-region 224 | (clim:frame-top-level-sheet frame)))) 225 | (clim:draw-rectangle* stream min-x min-y max-x max-y :filled t :ink clim:+grey70+))))) 226 | 227 | (defun bytes-to-string (object) 228 | (if (zerop object) 229 | "0" 230 | (let* ((suffixes '(" bytes" " KB" " MB" " GB" " TB" " PB")) 231 | (x (floor (realpart (log object 1000)))) 232 | (idx (min x (1- (length suffixes))))) 233 | (if (zerop idx) 234 | (format nil "~A bytes" object) 235 | (format nil "~,1F~A" (/ object (expt 1000 idx)) (nth idx suffixes)))))) 236 | 237 | (clim:define-command-table menubar-task-command-table 238 | :menu (("Clear interactor" :command (com-clear-interactor)) 239 | ("Quit" :command (com-quit)))) 240 | -------------------------------------------------------------------------------- /Apps/debugger/src/debugger.lisp: -------------------------------------------------------------------------------- 1 | #| CLIM Debugger 2 | 3 | TODO 4 | ---------------------------------------- 5 | - Elliott Johnson is to be thanked for the nice scroll-bars, but 6 | for some reason they don't remember their position when clicking 7 | on a stack-frame or "more". 8 | 9 | - The break function does not use the clim-debugger --> Christophe 10 | Rhodes was kind enough to inform me that on SBCL, 11 | SB-EXT:*INVOKE-DEBUGGER-HOOK* takes care off this problem. I 12 | still don't know if this is a problem with other compilers. 13 | 14 | - "Eval in frame" is not supported. I don't know of a good way to 15 | do this currently. 16 | 17 | - Goto source location is not supported, but I think this could be 18 | done through slime. 19 | 20 | - Currently the restart chosen by the clim-debugger is returned 21 | through the global variable *returned-restart*, this is not the 22 | best solution, but I do not know how of a better way to return a 23 | value from a clim frame, when it exits. 24 | 25 | - There need to added keyboard shortcuts. 'q' should exit the 26 | debugger with an abort. '0', '1' and so forth should activate 27 | the restarts, like Slime. Maybe is should be possible to use the 28 | arrow keys as well. Then we have to add a notion of the current 29 | frame. Would this be useful? 30 | 31 | |# 32 | 33 | (in-package desktop-debugger) 34 | 35 | (defmacro bold ((stream) &body body) 36 | `(clim:with-text-face (,stream :bold) 37 | ,@body)) 38 | 39 | 40 | 41 | 42 | ;;; CLIM stuff 43 | ;;; ---------------------------------------- 44 | 45 | (defclass debugger-pane (clim:application-pane) 46 | ((condition-info :reader condition-info :initarg :condition-info))) 47 | 48 | (defmethod condition-info (p) 49 | deski::*condition*) 50 | 51 | ;; FIXME - These two variables should be removed! 52 | ;; Used to return the chosen reatart in the debugger. 53 | (defparameter *returned-restart* nil) 54 | 55 | 56 | 57 | (defun make-debugger-pane () 58 | (clim:with-look-and-feel-realization ((clim:frame-manager clim:*application-frame*) 59 | clim:*application-frame*) 60 | (clim:make-pane 'debugger-pane 61 | :condition-info deski::*condition* 62 | :display-function #'display-debugger 63 | :end-of-line-action :allow 64 | :end-of-page-action :scroll))) 65 | 66 | (clim:define-application-frame clim-debugger (;;esa::esa-frame-mixin 67 | clim:standard-application-frame) 68 | ;;() 69 | ;;(:esa-gui t :presentation-history? t) 70 | () 71 | (:pointer-documentation t) 72 | (:panes (debugger-pane (make-debugger-pane)) 73 | (interactor :interactor)) 74 | (:layouts (:default (clim:vertically () 75 | (clim:scrolling () debugger-pane) 76 | (250 interactor)))) 77 | (:geometry :height 600 :width 800)) 78 | 79 | (defun run-debugger-frame () 80 | (clim:run-frame-top-level 81 | (clim:make-application-frame 'clim-debugger))) 82 | 83 | (clim:define-presentation-type pr-stack-frame () :inherit-from 'deski::stack-frame) 84 | (clim:define-presentation-type more-type ()) 85 | (clim:define-presentation-type inspect ()) 86 | 87 | (define-clim-debugger-command (com-more :name "More backtraces") 88 | ((pane 'more-type :default (clim:find-pane-named clim:*application-frame* 'debugger-pane))) 89 | (deski::expand-backtrace (condition-info pane) 10)) 90 | 91 | (define-clim-debugger-command (com-invoke-inspector :name "Invoke inspector") 92 | ((obj 'inspect)) 93 | (clouseau:inspect obj)) 94 | 95 | (define-clim-debugger-command (com-refresh :name "Refresh" :menu t) () 96 | (clim:change-space-requirements (clim:frame-panes clim:*application-frame*))) 97 | 98 | (define-clim-debugger-command (com-quit :name "Quit" :menu t) () 99 | (clim:frame-exit clim:*application-frame*)) 100 | 101 | (define-clim-debugger-command (com-invoke-restart :name "Invoke restart") 102 | ((restart 'deski::restart)) 103 | (setf *returned-restart* restart) 104 | (clim:frame-exit clim:*application-frame*)) 105 | 106 | (define-clim-debugger-command (com-toggle-stack-frame-view 107 | :name "Toggle stack frame view") 108 | ((stack-frame 'deski::stack-frame)) 109 | (progn 110 | (if (eq deski::+minimized-stack-frame-view+ (deski::view stack-frame)) 111 | (setf (deski::view stack-frame) deski::+maximized-stack-frame-view+) 112 | (setf (deski::view stack-frame) deski::+minimized-stack-frame-view+)) 113 | (clim:change-space-requirements (clim:frame-panes clim:*application-frame*)))) 114 | 115 | (clim:define-presentation-to-command-translator more-backtraces 116 | (more-type com-more clim-debugger :gesture :select) 117 | (object) 118 | (list object)) 119 | 120 | (clim:define-presentation-to-command-translator invoke-inspector 121 | (inspect com-invoke-inspector clim-debugger :gesture :select) 122 | (object) 123 | (list object)) 124 | 125 | (clim:define-presentation-to-command-translator toggle-stack-frame-view 126 | (pr-stack-frame com-toggle-stack-frame-view clim-debugger :gesture :select) 127 | (object) 128 | (list object)) 129 | 130 | (clim:define-presentation-to-command-translator invoke-restart 131 | (restart com-invoke-restart clim-debugger :gesture :select) 132 | (object) 133 | (list object)) 134 | 135 | (defun std-form (pane first second &key (family :sans-serif)) 136 | (clim:formatting-row 137 | (pane) 138 | (clim:with-text-family (pane :sans-serif) 139 | (clim:formatting-cell (pane) (bold (pane) (format t "~A" first)))) 140 | (clim:formatting-cell (pane) 141 | (clim:with-text-family (pane family) 142 | (format t "~A" second))))) 143 | 144 | (defun display-debugger (frame pane) 145 | (let ((*standard-output* pane)) 146 | (clim:formatting-table (pane) 147 | (std-form pane "Condition type:" (deski::type-of-condition (condition-info 148 | pane))) 149 | (std-form pane "Description:" (deski::condition-message (condition-info 150 | pane))) 151 | (when (deski::condition-extra (condition-info pane)) 152 | (std-form pane "Extra:" (deski::condition-extra (condition-info pane)) 153 | :family :fix))) 154 | (fresh-line) 155 | 156 | (clim:with-text-family (pane :sans-serif) 157 | (bold (pane) (format t "Restarts:"))) 158 | (fresh-line) 159 | (format t " ") 160 | (clim:formatting-table 161 | (pane) 162 | (loop 163 | for r in (deski::restarts (condition-info pane)) 164 | for i from 0 165 | do (clim:formatting-row (pane) 166 | (clim:with-output-as-presentation (pane r 'deski::restart :single-box t) 167 | (clim:formatting-cell (pane) 168 | (bold (pane) (format pane "~A: " i))) 169 | (clim:formatting-cell (pane) 170 | (clim:with-drawing-options (pane :ink clim:+deep-pink+) 171 | (format pane "[~A]" (restart-name r)))) 172 | (clim:formatting-cell (pane) 173 | (clim:with-text-family (pane :sans-serif) 174 | (format pane "~A" r))))))) 175 | (fresh-line) 176 | (display-backtrace frame pane) 177 | (clim:change-space-requirements pane 178 | :width (clim:bounding-rectangle-width (clim:stream-output-history pane)) 179 | :height (clim:bounding-rectangle-height (clim:stream-output-history pane))))) 180 | 181 | (defun display-backtrace (frame pane) 182 | (declare (ignore frame)) 183 | (clim:with-text-family (pane :sans-serif) 184 | (bold (pane) (format t "Backtrace:"))) 185 | (fresh-line) 186 | (format t " ") 187 | (clim:formatting-table 188 | (pane) 189 | (loop for stack-frame in (deski::backtrace (condition-info pane)) 190 | for i from 0 191 | do (clim:formatting-row (pane) 192 | (clim:with-output-as-presentation (pane stack-frame 'deski::stack-frame) 193 | (bold (pane) (clim:formatting-cell (pane) (format t "~A: " i))) 194 | (clim:formatting-cell (pane) 195 | (clim:present stack-frame 'pr-stack-frame 196 | :view (deski::view stack-frame)))))) 197 | (when (>= (length (deski::backtrace (condition-info pane))) 20) 198 | (clim:formatting-row (pane) 199 | (clim:formatting-cell (pane)) 200 | (clim:formatting-cell (pane) 201 | (bold (pane) 202 | (clim:present pane 'more-type))))))) 203 | 204 | (clim:define-presentation-method clim:present (object (type pr-stack-frame) stream 205 | (view deski::minimized-stack-frame-view) 206 | &key acceptably for-context-type) 207 | (declare (ignore acceptably for-context-type)) 208 | (let ((str (deski::frame-string object))) 209 | (format t "~A " 210 | (if (> (length str) 300) 211 | (subseq str 0 300) 212 | str)))) 213 | 214 | (clim:define-presentation-method clim:present (object (type pr-stack-frame) stream 215 | (view deski::maximized-stack-frame-view) 216 | &key acceptably for-context-type) 217 | (declare (ignore acceptably for-context-type)) 218 | (progn 219 | (princ (deski::frame-string object) stream) 220 | (fresh-line) 221 | (clim:with-text-family (stream :sans-serif) 222 | (bold (stream) (format t " Locals:"))) 223 | (fresh-line) 224 | (format t " ") 225 | (clim:formatting-table 226 | (stream) 227 | (loop for (name n identifier id value val) in (deski::frame-variables object) 228 | do (clim:formatting-row 229 | (stream) 230 | (clim:formatting-cell (stream) (format t "~A" n)) 231 | (clim:formatting-cell (stream) (format t "=")) 232 | (clim:formatting-cell (stream) (clim:present val 'inspect))))) 233 | (fresh-line))) 234 | 235 | (clim:define-presentation-method clim:present (object (type more-type) stream 236 | (view clim:textual-view) 237 | &key acceptably for-context-type) 238 | (declare (ignore acceptably for-context-type)) 239 | (bold (stream) (format t "--- MORE ---"))) 240 | 241 | (clim:define-presentation-method clim:present (object (type inspect) stream 242 | (view clim:textual-view) 243 | &key acceptably for-context-type) 244 | (declare (ignore acceptably for-context-type)) 245 | (format t "~A" object)) 246 | 247 | ;;; Starting the debugger 248 | ;;; ---------------------------------------- 249 | 250 | (defun debugger (condition me-or-my-encapsulation) 251 | (swank-backend::call-with-debugging-environment 252 | (lambda () 253 | (unwind-protect 254 | (progn 255 | (setf 256 | deski::*condition* 257 | (deski::make-debugger-info condition)) 258 | (run-debugger-frame)) 259 | (let ((restart *returned-restart*)) 260 | (setf *returned-restart* nil) 261 | (setf deski::*condition* nil) 262 | (if restart 263 | (let ((*debugger-hook* me-or-my-encapsulation)) 264 | (invoke-restart-interactively restart)) 265 | (abort))))))) 266 | -------------------------------------------------------------------------------- /Apps/apropos/gui/frame.lisp: -------------------------------------------------------------------------------- 1 | (in-package :desktop-apropos) 2 | 3 | 4 | ;;; 5 | ;;; utility 6 | ;;; 7 | 8 | (defun string-to-keyword (str) 9 | (if (string= str "nil") 10 | nil 11 | (intern (string-upcase str) :keyword))) 12 | 13 | ;;; 14 | ;;; application frame 15 | ;;; 16 | 17 | (clim:define-application-frame apropos-navigator () 18 | ((selected-values :initform nil) 19 | (selected-result-options :initform '(:fully-qualified)) 20 | (selected-output-option :initform ':selection) 21 | (selected-action-option :initform ':single) 22 | (symbol-view :initform +fully-qualified-symbol-view+) 23 | (iapropos :initform (make-instance 'iapropos))) 24 | (:command-table (apropos-navigator 25 | :inherit-from (edit-menu) 26 | :menu (("Edit" :menu edit-menu)))) 27 | (:menu-bar t) 28 | (:panes 29 | (symbol-regex-text-field :text-field 30 | :value-changed-callback '%update-matching-symbols) 31 | (package-regex-text-field :text-field 32 | :value-changed-callback '%update-matching-packages) 33 | (symbol-result-display :application 34 | :incremental-redisplay t 35 | :display-function '%render-symbol-result 36 | :display-time nil 37 | :scroll-bars :vertical 38 | :end-of-line-action :allow 39 | :end-of-page-action :allow 40 | :min-width 250) 41 | (package-result-display :application 42 | :incremental-redisplay t 43 | :display-function '%render-package-result 44 | :display-time nil 45 | :scroll-bars :vertical 46 | :end-of-line-action :allow 47 | :end-of-page-action :allow 48 | :min-width 190 49 | :max-width 400) 50 | (output-display :application 51 | :incremental-redisplay t 52 | :display-function '%render-output 53 | :scroll-bars :vertical 54 | :end-of-page-action :allow) 55 | (result-options 56 | (clim:with-radio-box (:type :some-of 57 | :orientation :horizontal 58 | :value-changed-callback '%update-result-options) 59 | (clim:radio-box-current-selection "fully-qualified"))) 60 | (output-option 61 | (clim:with-radio-box (:orientation :horizontal 62 | :value-changed-callback '%update-output-option) 63 | (clim:radio-box-current-selection "selection") 64 | "documentation" "location" "description" "object")) 65 | (external-option 66 | (clim:with-radio-box (:orientation :horizontal 67 | :value-changed-callback '%update-external-option) 68 | "yes" 69 | "no" 70 | (clim:radio-box-current-selection "nil"))) 71 | (documentation-option 72 | (clim:with-radio-box (:orientation :horizontal 73 | :value-changed-callback '%update-documentation-option) 74 | "yes" 75 | "no" 76 | (clim:radio-box-current-selection "nil"))) 77 | (bound-to-option 78 | (clim:with-radio-box (:orientation :vertical 79 | :value-changed-callback '%update-bound-to-option) 80 | (clim:radio-box-current-selection "nil") "variable" 81 | "function" "class" "generic-function" "macro" 82 | "setf" "type")) 83 | (subclass-option :option-pane 84 | :value nil 85 | :active nil 86 | :items *apropos-navigator-subclas-of-options* 87 | :name-key #'car 88 | :value-key #'cdr 89 | :value-changed-callback #'%update-subclass-option) 90 | (metaclass-option :option-pane 91 | :value nil 92 | :active nil 93 | :items *apropos-navigator-metaclas-of-options* 94 | :name-key #'car 95 | :value-key #'cdr 96 | :value-changed-callback #'%update-metaclass-option) 97 | (preselect-option :option-pane 98 | :value nil 99 | :items *apropos-navigator-preselect-options* 100 | :name-key #'car 101 | :value-key #'cdr 102 | :value-changed-callback #'%update-preselect-option) 103 | (action-option 104 | (clim:with-radio-box (:orientation :horizontal 105 | :value-changed-callback '%update-action-option) 106 | (clim:radio-box-current-selection "single") "multiple")) 107 | (return-action :push-button 108 | :activate-callback #'(lambda (gadget) 109 | (declare (ignore gadget)) 110 | (com-quit)) 111 | :label "return") 112 | (copy-action :push-button 113 | :activate-callback #'(lambda (gadget) 114 | (declare (ignore gadget)) 115 | (com-edit-copy-to-clipboard)) 116 | :label "clipboard") 117 | (kill-ring-action :push-button 118 | :activate-callback #'(lambda (gadget) 119 | (declare (ignore gadget)) 120 | (com-edit-copy-to-kill-ring)) 121 | :label "kill-ring")) 122 | (:layouts 123 | (:default 124 | (clim:horizontally nil 125 | (clim:vertically nil 126 | (clim:labelling (:label "Symbol") 127 | (clim:vertically nil 128 | (clim:labelling (:label "bound to") 129 | bound-to-option) 130 | (clim:labelling (:label "external") 131 | external-option) 132 | (clim:labelling (:label "documentation") 133 | documentation-option))) 134 | (clim:labelling (:label "Class") 135 | (clim:vertically nil 136 | (clim:labelling (:label "subclass of") 137 | subclass-option) 138 | (clim:labelling (:label "metaclass of") 139 | metaclass-option))) 140 | (clim:labelling (:label "Preselect") 141 | preselect-option) 142 | (clim:labelling (:label "Selection") 143 | action-option) 144 | (clim:+fill+)) 145 | (clim:+fill+ 146 | (clim:vertically nil 147 | (2/3 (clim:labelling (:label "Results") 148 | (clim:vertically nil 149 | result-options 150 | (clim:horizontally nil 151 | (2/5 package-result-display) 152 | (3/5 symbol-result-display))))) 153 | (1/3 (clim:labelling (:label "Output") 154 | (clim:vertically nil 155 | output-option 156 | output-display))) 157 | (clim:horizontally nil 158 | (clim:labelling (:label "Copy to") 159 | (clim:vertically nil 160 | copy-action 161 | kill-ring-action)) 162 | (clim:+fill+ 163 | (clim:vertically nil 164 | (clim:labelling (:label "symbol apropos" :align-x :center) 165 | symbol-regex-text-field) 166 | (clim:labelling (:label "package apropos" :align-x :center) 167 | package-regex-text-field)))))))))) 168 | 169 | ;;; 170 | ;;; frame initialization 171 | ;;; 172 | 173 | (defmethod clim::note-frame-enabled ((fm clim:frame-manager) (frame apropos-navigator)) 174 | (setf (clim:command-enabled 'com-edit-select-all clim:*application-frame*) nil) 175 | (setf (clim:command-enabled 'com-edit-select-none clim:*application-frame*) nil)) 176 | 177 | ;;; 178 | ;;; input/output 179 | ;;; 180 | 181 | (defmethod clim:frame-standard-input ((frame apropos-navigator)) 182 | (car (clim:sheet-children 183 | (clim:find-pane-named clim:*application-frame* 'symbol-regex-text-field)))) 184 | 185 | ;;; 186 | ;;; callbacks 187 | ;;; 188 | 189 | (defun %update-matching-packages (this-gadget value) 190 | (declare (ignore this-gadget)) 191 | (anaphora:awhen (clim:find-pane-named clim:*application-frame* 'output-display) 192 | (clim:window-clear anaphora:it)) 193 | (with-slots (iapropos) clim:*application-frame* 194 | (handler-bind ((cl-ppcre:ppcre-syntax-error 195 | #'(lambda (condition) 196 | (%print-error 197 | condition 198 | (clim:find-pane-named clim:*application-frame* 'output-display)) 199 | (%maybe-update-package-result-display) 200 | (%maybe-update-symbol-result-display) 201 | (return-from %update-matching-packages)))) 202 | (setf (iapropos-package-text iapropos) value))) 203 | (%maybe-update-package-result-display) 204 | (%maybe-update-symbol-result-display)) 205 | 206 | (defun %update-matching-symbols (this-gadget value) 207 | (declare (ignore this-gadget)) 208 | (anaphora:awhen (clim:find-pane-named clim:*application-frame* 'output-display) 209 | (clim:window-clear anaphora:it)) 210 | (with-slots (iapropos) clim:*application-frame* 211 | (handler-bind ((cl-ppcre:ppcre-syntax-error 212 | #'(lambda (condition) 213 | (%print-error 214 | condition 215 | (clim:find-pane-named clim:*application-frame* 'output-display)) 216 | (%maybe-update-package-result-display) 217 | (%maybe-update-symbol-result-display) 218 | (return-from %update-matching-symbols)))) 219 | (setf (iapropos-symbol-text iapropos) value))) 220 | (%maybe-update-symbol-result-display)) 221 | 222 | (defun %update-bound-to-option (this-gadget selected-gadget) 223 | (declare (ignore this-gadget)) 224 | (with-slots (iapropos) clim:*application-frame* 225 | (setf (iapropos-bound-to iapropos) 226 | (string-to-keyword (clim:gadget-label selected-gadget)))) 227 | (if (string= (clim:gadget-label selected-gadget) "class") 228 | (progn 229 | (clim:activate-gadget (clim:find-pane-named clim:*application-frame* 'subclass-option)) 230 | (clim:activate-gadget (clim:find-pane-named clim:*application-frame* 'metaclass-option))) 231 | (progn 232 | (clim:deactivate-gadget (clim:find-pane-named clim:*application-frame* 'subclass-option)) 233 | (clim:deactivate-gadget (clim:find-pane-named clim:*application-frame* 'metaclass-option)))) 234 | (if (string/= (clim:gadget-label selected-gadget) "nil") 235 | (clim:activate-gadget (clim:find-pane-named clim:*application-frame* 'documentation-option)) 236 | (clim:deactivate-gadget (clim:find-pane-named clim:*application-frame* 'documentation-option))) 237 | (%maybe-update-symbol-result-display)) 238 | 239 | (defun %update-external-option (this-gadget selected-gadget) 240 | (declare (ignore this-gadget)) 241 | (with-slots (iapropos) clim:*application-frame* 242 | (setf (iapropos-external-yes/no iapropos) 243 | (string-to-keyword (clim:gadget-label selected-gadget)))) 244 | (%maybe-update-symbol-result-display)) 245 | 246 | (defun %update-documentation-option (this-gadget selected-gadget) 247 | (declare (ignore this-gadget)) 248 | (with-slots (iapropos) clim:*application-frame* 249 | (setf (iapropos-documentation-yes/no iapropos) 250 | (string-to-keyword (clim:gadget-label selected-gadget)))) 251 | (%maybe-update-symbol-result-display)) 252 | 253 | (defun %update-subclass-option (this-gadget selected-value) 254 | (declare (ignore this-gadget)) 255 | (with-slots (iapropos) clim:*application-frame* 256 | (setf (iapropos-subclass-of iapropos) selected-value)) 257 | (%maybe-update-symbol-result-display)) 258 | 259 | (defun %update-metaclass-option (this-gadget selected-value) 260 | (declare (ignore this-gadget)) 261 | (with-slots (iapropos) clim:*application-frame* 262 | (setf (iapropos-metaclass-of iapropos) selected-value)) 263 | (%maybe-update-symbol-result-display)) 264 | 265 | (defun %update-preselect-option (this-gadget selected-value) 266 | (declare (ignore this-gadget)) 267 | (if selected-value 268 | (progn 269 | (clim:deactivate-gadget (clim:find-pane-named clim:*application-frame* 'bound-to-option)) 270 | (clim:deactivate-gadget (clim:find-pane-named clim:*application-frame* 'subclass-option)) 271 | (clim:deactivate-gadget (clim:find-pane-named clim:*application-frame* 'metaclass-option)) 272 | (with-slots (iapropos) clim:*application-frame* 273 | (funcall selected-value iapropos))) 274 | (progn 275 | (setf (clim:gadget-value 276 | (clim:find-pane-named clim:*application-frame* 'bound-to-option)) "nil") 277 | (setf (clim:gadget-value 278 | (clim:find-pane-named clim:*application-frame* 'subclass-option)) nil) 279 | (setf (clim:gadget-value 280 | (clim:find-pane-named clim:*application-frame* 'metaclass-option)) nil) 281 | (clim:activate-gadget (clim:find-pane-named clim:*application-frame* 'bound-to-option)) 282 | (with-slots (iapropos) clim:*application-frame* 283 | (setf (iapropos-filter-fn iapropos) nil) 284 | (setf (iapropos-subclass-of iapropos) nil) 285 | (setf (iapropos-metaclass-of iapropos) nil) 286 | (setf (iapropos-bound-to iapropos) nil)))) 287 | (%maybe-update-symbol-result-display)) 288 | 289 | (defun %update-output-option (this-gadget selected-gadget) 290 | (declare (ignore this-gadget)) 291 | (with-slots (selected-output-option) clim:*application-frame* 292 | (setf selected-output-option 293 | (intern (string-upcase (clim:gadget-label selected-gadget)) :keyword))) 294 | (%maybe-update-output-display)) 295 | 296 | (defun %update-result-options (this-gadget selected-gadgets) 297 | (declare (ignore this-gadget)) 298 | (with-slots (selected-result-options symbol-view) clim:*application-frame* 299 | (setf selected-result-options nil) 300 | (dolist (sg selected-gadgets) 301 | (push 302 | (string-to-keyword (clim:gadget-label sg)) 303 | selected-result-options)) 304 | (if (member :fully-qualified selected-result-options) 305 | (setf symbol-view +fully-qualified-symbol-view+) 306 | (setf symbol-view clim:+textual-view+))) 307 | (%maybe-update-symbol-result-display)) 308 | 309 | (defun %update-action-option (this-gadget selected-gadget) 310 | (declare (ignore this-gadget)) 311 | (with-slots (selected-action-option selected-values) clim:*application-frame* 312 | (setf selected-action-option 313 | (string-to-keyword (clim:gadget-label selected-gadget))) 314 | (if (eq selected-action-option :single) 315 | (progn 316 | (setf selected-values (when selected-values (list (car selected-values)))) 317 | (setf (clim:command-enabled 'com-edit-select-all clim:*application-frame*) nil) 318 | (setf (clim:command-enabled 'com-edit-select-none clim:*application-frame*) nil) 319 | (%maybe-update-symbol-result-display) 320 | (%maybe-update-output-display)) 321 | (progn 322 | (setf (clim:command-enabled 'com-edit-select-all clim:*application-frame*) t) 323 | (setf (clim:command-enabled 'com-edit-select-none clim:*application-frame*) t))))) 324 | 325 | (defun %maybe-update-symbol-result-display (&rest _) 326 | (declare (ignore _)) 327 | (anaphora:awhen (clim:find-pane-named clim:*application-frame* 'symbol-result-display) 328 | (clim:redisplay-frame-pane clim:*application-frame* anaphora:it :force-p t))) 329 | 330 | (defun %maybe-update-package-result-display (&rest _) 331 | (declare (ignore _)) 332 | (anaphora:awhen (clim:find-pane-named clim:*application-frame* 'package-result-display) 333 | (clim:redisplay-frame-pane clim:*application-frame* anaphora:it :force-p t))) 334 | 335 | (defun %maybe-update-output-display (&rest _) 336 | (declare (ignore _)) 337 | (anaphora:awhen (clim:find-pane-named clim:*application-frame* 'output-display) 338 | (clim:redisplay-frame-pane clim:*application-frame* anaphora:it :force-p t))) 339 | 340 | ;;; 341 | ;;; render functions 342 | ;;; 343 | 344 | (defun %print-heading-text (text pane) 345 | (fresh-line pane) 346 | (clim:stream-increment-cursor-position pane 10 5) 347 | (clim:surrounding-output-with-border 348 | (pane :shape :underline :ink clim:+black+) 349 | (clim:with-text-style (pane *apropos-navigator-heading-text-style*) 350 | (princ text pane)))) 351 | 352 | (defun %print-sub-heading-text (text pane) 353 | (fresh-line pane) 354 | (clim:stream-increment-cursor-position pane 10 5) 355 | (clim:surrounding-output-with-border 356 | (pane :shape :underline :ink clim:+black+) 357 | (clim:with-text-style (pane *apropos-navigator-sub-heading-text-style*) 358 | (princ text pane)))) 359 | 360 | (defun %print-error (condition pane) 361 | (fresh-line pane) 362 | (clim:stream-increment-cursor-position pane 10 5) 363 | (clim:with-drawing-options (pane :ink clim:+red+) 364 | (%print-heading-text "Syntax Error" pane) 365 | (fresh-line pane) 366 | (clim:stream-increment-cursor-position pane 10 0) 367 | (princ condition pane))) 368 | 369 | (defun %print-text (pane text &optional (x-offset 0)) 370 | (fresh-line pane) 371 | (clim:stream-increment-cursor-position pane (+ x-offset 10) 0) 372 | (princ text pane)) 373 | 374 | (defun take (n l) 375 | (subseq l 0 (if (< (length l) n) (if (> n (1- (length l))) (length l) (1- (length l))) n))) 376 | 377 | (defun %render-output (frame pane) 378 | (declare (ignore frame)) 379 | (declare (ignore frame)) 380 | (with-slots (selected-values selected-output-option iapropos) clim:*application-frame* 381 | (flet ((print-symbol (sym type opt) 382 | (ccase opt 383 | (:selection 384 | (%print-sub-heading-text (format nil "Selected symbols") pane) 385 | (let ((*print-escape* t)) 386 | (dolist (v selected-values) 387 | (fresh-line pane) 388 | (clim:stream-increment-cursor-position pane 10 0) 389 | (clim:present v 'symbol :stream pane :view +fully-qualified-symbol-view+) 390 | (clim:stream-increment-cursor-position pane 10 0) 391 | (anaphora:awhen (list-symbol-bounding-types v) 392 | (princ anaphora:it pane))))) 393 | (:object 394 | (%print-sub-heading-text (format nil "Object (~A)" type) pane) 395 | (let ((obj (symbol-object sym type))) 396 | (when obj 397 | (fresh-line pane) 398 | (clim:stream-increment-cursor-position pane 10 0) 399 | (clim:present obj 'object 400 | :stream pane :view clim:+textual-view+)))) 401 | (:location 402 | (%print-sub-heading-text (format nil "Location (~A)" type) pane) 403 | (let ((loc (symbol-location sym type))) 404 | (when loc 405 | (fresh-line pane) 406 | (clim:stream-increment-cursor-position pane 10 0) 407 | (clim:present loc 'source-location 408 | :stream pane :view clim:+textual-view+)))) 409 | (:documentation 410 | (%print-sub-heading-text (format nil "Documentation (~A)" type) pane) 411 | (let ((doc (symbol-documentation (car selected-values) type))) 412 | (when doc 413 | (%print-text pane doc)))) 414 | (:description 415 | (%print-sub-heading-text (format nil "Description (~A)" type) pane) 416 | (let ((des (symbol-description (car selected-values) type))) 417 | (when des 418 | (%print-text pane des))))) 419 | (clim:stream-increment-cursor-position pane 0 5))) 420 | (if (null selected-values) 421 | (%print-heading-text (format nil "Empty selection") pane) 422 | (if (eq selected-output-option :selection) 423 | (print-symbol selected-values nil selected-output-option) 424 | (dolist (sym selected-values) 425 | (let ((*print-escape* t)) 426 | (%print-heading-text (format nil "~S" sym) pane)) 427 | (if (iapropos-bound-to iapropos) 428 | (print-symbol sym 429 | (iapropos-bound-to iapropos) selected-output-option) 430 | (dolist (type (list-symbol-bounding-types sym)) 431 | (print-symbol sym type selected-output-option))))))))) 432 | 433 | (defun %render-symbol-result (frame pane) 434 | (declare (ignore frame)) 435 | (with-slots (iapropos selected-values symbol-view) 436 | clim:*application-frame* 437 | (let* ((matching-symbols (iapropos-matching-symbols iapropos)) 438 | (symbols-to-print (take 400 matching-symbols))) 439 | (%print-heading-text (format nil "Symbols (~A/~A~A)" 440 | (length symbols-to-print) 441 | (length matching-symbols) 442 | (if (iapropos-result-overflow-p iapropos) "*" "")) pane) 443 | (if (null matching-symbols) 444 | (progn 445 | (fresh-line pane) 446 | (clim:stream-increment-cursor-position pane 5 0) 447 | (princ "; no results" pane)) 448 | (dolist (sym symbols-to-print) 449 | (fresh-line pane) 450 | (clim:stream-increment-cursor-position pane 10 0) 451 | (clim:with-drawing-options (pane :ink 452 | (if (member sym selected-values) 453 | clim:+blue+ 454 | clim:+black+)) 455 | (clim:present sym 'symbol :stream pane :view symbol-view))))))) 456 | 457 | (defun %render-package-result (frame pane) 458 | (declare (ignore frame)) 459 | (with-slots (iapropos) 460 | clim:*application-frame* 461 | (let* ((matching-packages (iapropos-matching-packages iapropos))) 462 | (%print-heading-text (format nil "Packages (~A)" (length matching-packages)) pane) 463 | (if (null matching-packages) 464 | (progn 465 | (fresh-line pane) 466 | (clim:stream-increment-cursor-position pane 5 0) 467 | (princ "; no results" pane)) 468 | (dolist (package matching-packages) 469 | (fresh-line pane) 470 | (clim:stream-increment-cursor-position pane 5 0) 471 | (clim:present package 'package :stream pane :view clim:+textual-view+)))))) 472 | 473 | ;;; 474 | ;;; return values 475 | ;;; 476 | 477 | (defvar *return-values* nil) 478 | 479 | (defun %update-return-values () 480 | (with-slots (selected-values selected-action-option iapropos) clim:*application-frame* 481 | (setf *return-values* 482 | (ccase selected-action-option 483 | (:single 484 | (car selected-values)) 485 | (:multiple 486 | (remove-duplicates selected-values)))))) 487 | 488 | ;;; 489 | ;;; 490 | ;;; 491 | 492 | (defmacro with-fixed-vertical-scroll-bar (pane &body body) 493 | (let ((vscrollbar (gensym "VSCROLLBAR")) 494 | (vsb-value (gensym "VSB-VALUE"))) 495 | `(let* ((,vscrollbar (slot-value (clim:sheet-parent 496 | (clim:sheet-parent 497 | ,pane)) 498 | 'climi::vscrollbar)) 499 | (,vsb-value (slot-value ,vscrollbar 'climi::value))) 500 | ,@body 501 | (progn 502 | (climi::drag-callback ,vscrollbar nil nil ,vsb-value) 503 | (setf (clim:gadget-value ,vscrollbar) ,vsb-value))))) 504 | --------------------------------------------------------------------------------