From c82faf953d0d200530e7c14d510a13f09023c59c Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 4 Jan 2021 13:56:45 +0100 Subject: Move Elisp to separate file. --- guile-studio.el | 544 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 544 insertions(+) create mode 100644 guile-studio.el (limited to 'guile-studio.el') diff --git a/guile-studio.el b/guile-studio.el new file mode 100644 index 0000000..5df2c9f --- /dev/null +++ b/guile-studio.el @@ -0,0 +1,544 @@ +;; (defvar %guile-studio/prefix "@PREFIX@") +;; (defvar %guile-studio/picture-language "@PICTURE_LANGUAGE@") +;; (defvar %guile-studio/emacsdir "@EMACSDIR@") +;; (defvar %guile-studio/guiledir "@GUILEDIR@") +;; (defvar %guile-studio/guile-load-path "@GUILE_LOAD_PATH@") +;; (defvar %guile-studio/guile-load-compiled-path "@GUILE_LOAD_COMPILED_PATH@") + + +(let ((guix-emacs.el + (expand-file-name + (concat %guile-studio/emacsdir "/share/emacs/site-lisp/guix-emacs.el")))) + (when (file-exists-p guix-emacs.el) + (load guix-emacs.el))) +(when (require 'guix-emacs nil t) + (guix-emacs-autoload-packages)) + +(setq-default line-spacing 2) +;; Increase default font size +(set-face-attribute 'default nil :height 112) + +(setq-default indent-tabs-mode nil) +(tool-bar-mode -1) +(menu-bar-mode 1) +(scroll-bar-mode -1) + +(setq window-resize-pixelwise t) + +;; Show only buffers with the same major mode in the same tab line. +(require 'tab-line) +(setq tab-line-tabs-function 'tab-line-tabs-mode-buffers) +(setq tab-line-close-tab-function 'kill-buffer) + +(require 'ivy) +(ivy-mode 1) +;; Enter directory when hitting RET +(define-key ivy-minibuffer-map (kbd "") 'ivy-alt-done) + +(require 'info) +(setq Info-directory-list + (list (concat %guile-studio/prefix "/share/guile-studio/info/") + (concat %guile-studio/picture-language "/share/info/") + (concat %guile-studio/guiledir "/share/info/"))) + +;; Use Ctrl-C/X/Z for copy, cut, paste +(require 'cua-base) +(cua-mode 1) +(require 'company) +(setq company-idle-delay 0.3) +(require 'elec-pair) +(electric-pair-mode 1) +(require 'scheme) +(require 'geiser) + +;; Add site-ccache directories to %load-compiled-path, and run the +;; init routine. We don't use geiser-guile-init-file because that +;; would lead to compilation messages in the REPL when Guile +;; Studio is first started. +(defun guile-studio--geiser-guile--parameters (params) + (append (list "-C" (concat %guile-studio/prefix "/lib/guile/3.0/site-ccache/")) + (mapcan (lambda (dir) (list "-C" dir)) + %guile-studio/guile-load-compiled-path) + params + (list "-e" "(@ (guile-studio-init) guile-studio-init)"))) +(advice-add 'geiser-guile--parameters + :filter-return (function guile-studio--geiser-guile--parameters)) +(setq geiser-guile-load-path + (mapcan (lambda (dir) (list "-C" dir)) + %guile-studio/guile-load-path)) + +(setq geiser-autodoc-identifier-format "%s → %s") +(setq geiser-default-implementation 'guile + geiser-active-implementations '(guile) + geiser-mode-smart-tab-p t + + initial-major-mode 'scheme-mode + inhibit-splash-screen t + confirm-kill-processes nil ; kill Geiser on exit + x-select-enable-clipboard t + x-select-enable-primary t + save-interprogram-paste-before-kill t + apropos-do-all t + mouse-yank-at-point t + require-final-newline t + visible-bell nil + load-prefer-newer t + save-place-file (concat user-emacs-directory "places")) + +(setq ring-bell-function + (lambda () + (let ((orig-fg (face-foreground 'mode-line))) + (set-face-foreground 'mode-line "#F2804F") + (run-with-idle-timer 0.1 nil + (lambda (fg) (set-face-foreground 'mode-line fg)) + orig-fg)))) + +;; Hide the fact that this is Emacs +(modify-frame-parameters nil '((title . "Guile Studio"))) + +(defun menu-bar-read-guileref () + "Display the Guile Reference manual in Info mode." + (interactive) + (info "guile")) +(defun menu-bar-read-pictref () + "Display the Picture Language manual in Info mode." + (interactive) + (info "picture-language")) + +(defun string-display-pixel-width (string) + "Calculate pixel width of STRING." + (with-temp-buffer + (with-silent-modifications + (setf (buffer-string) string)) + (variable-pitch-mode 1) + (if (get-buffer-window (current-buffer)) + (car (window-text-pixel-size nil (line-beginning-position) (point))) + (set-window-buffer nil (current-buffer)) + (car (window-text-pixel-size nil (line-beginning-position) (point)))))) + +(defun right-align (string &optional center-p) + (let ((right-margin 3)) + (concat + (propertize " " 'display + `(space :align-to + (- ,(if center-p 'center 'right) + (,(+ right-margin (string-display-pixel-width string)))))) + string))) + +;; Adapted from fancy-splash-insert +(defun guile-studio-splash-insert (&rest args) + (let ((current-face nil)) + (while args + (cond ((eq (car args) :face) + (setq args (cdr args) current-face (car args)) + (if (functionp current-face) + (setq current-face (funcall current-face)))) + ((eq (car args) :link) + (setq args (cdr args)) + (let ((spec (car args))) + (if (functionp spec) + (setq spec (funcall spec))) + (insert-button (car spec) + 'face (list 'link current-face) + 'action (cadr spec) + 'help-echo (concat "mouse-2, RET: " + (or (nth 2 spec) + "Follow this link")) + 'follow-link t))) + (t + (insert (propertize (car args) 'face current-face)))) + (setq args (cdr args))))) + +(defvar about-guile-studio-text + `((:face variable-pitch + "Welcome to Guile Studio, an Emacs environment to play +with the " + :link ("GNU Guile programming language" + ,(lambda (_button) (browse-url "https://www.gnu.org/software/guile/")) + "Browse https://www.gnu.org/software/guile/") + " and its picture language.\n\n" + + :face modus-theme-heading-1 "Manuals\n" + :face variable-pitch + " Learn all about Guile " + :link (,(right-align "View Guile Manual") + ,(lambda (_button) (menu-bar-read-guileref))) + "\n" + " How to draw pictures " + :link (,(right-align "View Picture Language Manual") + ,(lambda (_button) (menu-bar-read-pictref))) + "\n\n" + :face modus-theme-heading-1 "Common commands\n" + :face variable-pitch + " Save " ,(right-align "C-x C-s" t) "\t" + " Help " ,(right-align "C-h") "\n" + + " Save as " ,(right-align "C-x C-w" t) "\t" + " Cancel " ,(right-align "C-g") "\n" + + " Open a new file " ,(right-align "C-x C-f" t) "\t" + " Undo " ,(right-align "C-/") "\n" + + " Close side window " ,(right-align "q" t) "\t" + " Close buffer " ,(right-align "C-x k") "\n" + + " Browse directory " ,(right-align "C-x d" t) "\t" + " Quit " ,(right-align "C-x C-c") "\n" + "\n" + "Access a context-specific menu by right-clicking.\n" + "Toggle between dark and light mode with F5." + "\n"))) + +(defun about-guile-studio () + "Display the Guile Studio about buffer." + (interactive) + (let ((splash-buffer (get-buffer-create "*Guile Studio*"))) + (with-current-buffer + splash-buffer + (let ((inhibit-read-only t)) + (erase-buffer) + (setq default-directory command-line-default-directory) + (make-local-variable 'startup-screen-inhibit-startup-screen) + (let* ((image-file (concat %guile-studio/prefix "/share/logo.svg")) + (img (create-image image-file)) + (image-width (and img (car (image-size img)))) + (window-width (window-width))) + (when img + (insert "\n") + (when (> window-width image-width) + ;; Center the image in the window. + (insert (propertize " " 'display + `(space :align-to (+ center (-0.5 . ,img))))) + + ;; Insert the image with a help-echo and a link. + (make-button (prog1 (point) (insert-image img)) (point) + 'face 'default + 'help-echo "mouse-2, RET: Browse https://www.gnu.org/software/guile" + 'action (lambda (_button) (browse-url "https://www.gnu.org/software/guile")) + 'follow-link t) + (insert "\n\n")))) + (dolist (text about-guile-studio-text) + (apply (function guile-studio-splash-insert) text) + (insert "\n"))) + (use-local-map splash-screen-keymap) + (setq buffer-read-only t) + (set-buffer-modified-p nil) + (if (and view-read-only (not view-mode)) + (view-mode-enter nil 'kill-buffer)) + (goto-char (point-min)) + (forward-line 4)) + (pop-to-buffer splash-buffer 'display-buffer-in-side-window))) + +;; Unclutter help menu. +(require 'menu-bar) +(setq menu-bar-help-menu + (let ((menu (make-sparse-keymap "Help"))) + (bindings--define-key menu (vector 'about-gnu-project) + '(menu-item "About GNU" describe-gnu-project + :help "About the GNU System, GNU Project, and GNU/Linux")) + (bindings--define-key menu (vector 'about-guile-studio) + '(menu-item "About Guile Studio" about-guile-studio + :help "About this program")) + (bindings--define-key menu (vector 'sep2) + menu-bar-separator) + (bindings--define-key menu (vector 'other-manuals) + '(menu-item "All Other Manuals (Info)" Info-directory + :help "Read any of the installed manuals")) + (bindings--define-key menu (vector 'guile-reference) + '(menu-item "Guile Reference" menu-bar-read-guileref + :help "Read the Guile Reference manual")) + menu)) +(bindings--define-key global-map (vector 'menu-bar 'help-menu) + (cons (purecopy "Help") menu-bar-help-menu)) + +;; Unclutter File menu +(setq menu-bar-file-menu + (let ((menu (make-sparse-keymap "File"))) + (bindings--define-key menu (vector 'exit-emacs) + '(menu-item "Quit" save-buffers-kill-terminal + :help "Save unsaved buffers, then exit")) + (bindings--define-key menu (vector 'sep-exit) + menu-bar-separator) + (bindings--define-key menu (vector 'revert-buffer) + '(menu-item "Revert Buffer" revert-buffer + :enable + (or + (not + (eq revert-buffer-function 'revert-buffer--default)) + (not + (eq revert-buffer-insert-file-contents-function + 'revert-buffer-insert-file-contents--default-function)) + (and buffer-file-number + (not + (verify-visited-file-modtime + (current-buffer))))) + :help "Re-read current buffer from its file")) + (bindings--define-key menu (vector 'write-file) + '(menu-item "Save As..." write-file + :enable menu-bar-menu-frame-live-and-visible-p + :help "Write current buffer to another file")) + (bindings--define-key menu (vector 'save-buffer) + '(menu-item "Save" save-buffer :enable + (and (buffer-modified-p) + (buffer-file-name)) + :help "Save current buffer to its file")) + (bindings--define-key menu (vector 'sep-save) + menu-bar-separator) + (bindings--define-key menu (vector 'kill-buffer) + '(menu-item "Close" kill-this-buffer :enable + (kill-this-buffer-enabled-p) + :help "Discard (kill) current buffer")) + + (bindings--define-key menu (vector 'dired) + '(menu-item "Open File..." dired-sidebar-show-sidebar + :help "Show the directory browser in a side bar")) + (bindings--define-key menu (vector 'new-file) + '(menu-item "New File" (lambda () + (interactive) + (select-window + (get-window-with-predicate + (lambda (window) + (window-parameter window 'guile-studio/edit)))) + (find-file "untitled.scm")) + :help "Create a new file buffer")) + menu)) +(bindings--define-key global-map (vector 'menu-bar 'file) + (cons (purecopy "File") menu-bar-file-menu)) + +;; Unclutter Edit menu +(define-key menu-bar-edit-menu (vector 'goto) nil) +(define-key menu-bar-edit-menu (vector 'bookmark) nil) +(define-key menu-bar-edit-menu (vector 'separator-bookmark) nil) +(define-key menu-bar-edit-menu (vector 'fill) nil) +(define-key menu-bar-edit-menu (vector 'props) nil) + +(define-key menu-bar-edit-menu (vector 'replace 'tags-repl) nil) +(define-key menu-bar-edit-menu (vector 'replace 'tags-repl-continue) nil) +(define-key menu-bar-edit-menu (vector 'search) + '(menu-item "Search..." isearch-forward-regexp + :help "Incrementally search for a regular expression")) + +;; Check syntax on the fly +(require 'flycheck) +(require 'flycheck-guile) +(global-flycheck-mode 1) + +;; Remember location in buffers +(require 'saveplace) +(setq-default save-place t) + +;; Right side window +(defvar popup-right-side-windows + (rx (or "*Guile Studio*" + "*Geiser documentation*" + (seq "*Help" (* anychar) "*") + "*info*"))) +(add-to-list 'display-buffer-alist + `(,popup-right-side-windows + (display-buffer-reuse-window + display-buffer-in-side-window) + (inhibit-same-window . t) + (side . right) + (slot . 0) + (preserve-size . (t . t)) + (window-width . 80) + (window-height . 1.0))) + +;; Bottom side window +(defvar popup-bottom-windows + (rx (or "*Flycheck*" + "*Flymake*" + "*Backtrace*" + "*Warnings*" + "*Compile-Log*" + "*Messages*" + (seq (* anychar) "*Completions" (* anychar))))) +(add-to-list 'display-buffer-alist + `(,popup-bottom-windows + (display-buffer-reuse-window + display-buffer-in-side-window) + (inhibit-same-window . t) + (side . bottom) + (slot . 0) + (preserve-size . (t . t)) + (window-height . 0.16))) + +(defvar bottom-windows + (rx (or (seq "* Guile REPL *" (* anychar)) + "*Geiser dbg*"))) +(add-to-list 'display-buffer-alist + `(,bottom-windows + (display-buffer-reuse-window + display-buffer-at-bottom) + (window-height . 10))) + +(require 'dired-sidebar) +(global-set-key (kbd "C-x d") 'dired-sidebar-toggle-sidebar) +;; Delete dired window on "q" +(define-key dired-mode-map (kbd "q") 'delete-window) +(setq dired-sidebar-one-instance-p t + dired-sidebar-close-sidebar-on-file-open t) + +;; Mode line settings +(require 'doom-modeline) +(setq doom-modeline-buffer-encoding nil) + +;; Remove incorrect help echo from buffer name +(require 'doom-modeline-segments) +(doom-modeline-def-segment buffer-info + (concat + (doom-modeline-spc) + (doom-modeline--buffer-mode-icon) + (doom-modeline--buffer-state-icon) + (propertize "%b" 'face 'doom-modeline-buffer-file))) +(doom-modeline-mode 1) + +;; Stop using the minibuffer when leaving it +(defun stop-using-minibuffer () + "kill the minibuffer" + (when (and (>= (recursion-depth) 1) (active-minibuffer-window)) + (abort-recursive-edit))) +(add-hook 'mouse-leave-buffer-hook 'stop-using-minibuffer) + +(require 'uniquify) +(setq uniquify-buffer-name-style 'forward) + +;; Add close button for opened buffers. +(require 'mouse) +(defconst my-mode-line-map + (let ((map (make-sparse-keymap))) + (define-key map (vector 'mode-line 'mouse-1) + 'mouse-delete-window) + map)) +(setq global-mode-string + (append global-mode-string + '(:eval (if (window-dedicated-p (selected-window)) + "" + (propertize "[⨯]" + 'local-map my-mode-line-map + 'mouse-face 'mode-line-highlight))))) +(global-unset-key (vector 'mode-line 'mouse-2)) ; 'mouse-delete-other-windows +(global-unset-key (vector 'mode-line 'mouse-3)) ; 'mouse-delete-window + +;; Don't switch buffers when clicking on the name. +(define-key mode-line-buffer-identification-keymap (vector 'mode-line 'mouse-1) nil) +(define-key mode-line-buffer-identification-keymap (vector 'mode-line 'mouse-3) nil) + +;; Context menu on right click. +(defun context-menu () + (let ((menu (make-sparse-keymap))) + (pcase major-mode + ('geiser-repl-mode + (define-key menu (vector 'insert-image) + '("Insert image" . geiser--guile-picture-language--pict-from-file)) + menu) + ('scheme-mode + (define-key menu (vector 'switch-to-repl) + '("Switch to REPL" . switch-to-geiser)) + (define-key menu (vector 'eval-buffer) + '("Evaluate buffer" . geiser-eval-buffer)) + (define-key menu (vector 'lookup-documentation) + '("Show documentation". geiser-doc-symbol-at-point)) + menu) + (t + (mouse-menu-major-mode-map))))) + +(global-set-key (vector 'mouse-3) + (lambda (event) + (interactive "e") + (mouse-set-point event) + (popup-menu (context-menu)))) + +(defun geiser--guile-picture-language--pict-from-file () + (interactive) + (let ((file (read-file-name "Insert image: " nil nil t nil + (lambda (name) + (or (string-suffix-p ".svg" name t) + (string-suffix-p ".png" name t)))))) + (geiser-repl--send + (concat "(pict-from-file \"" + file + "\")")))) + +(add-to-list 'initial-frame-alist + '(fullscreen . maximized)) + +(add-hook 'emacs-startup-hook + (lambda () + (require 'winner) + (winner-mode 1) + (let ((buf (generate-new-buffer "untitled.scm"))) + (with-current-buffer buf + (switch-to-buffer buf nil t) + (set-window-dedicated-p (selected-window) nil) + (set-window-parameter (selected-window) 'guile-studio/edit t) + (funcall (and initial-major-mode)) + (insert ";;; Welcome to Guile Studio!\n") + (insert ";;; Type your Guile program here and evaluate it.\n\n") + (setq buffer-offer-save t) + + (switch-to-geiser) + (set-window-dedicated-p (selected-window) t) + (call-interactively 'about-guile-studio)) + + ;; This is necessary to show the REPL prompt after + ;; displaying the side window. + (pop-to-buffer "* Guile REPL *")) + + ;; Always restore default layout + (defvar guile-studio--layout (winner-conf)) + (define-key global-map (kbd "ESC ESC ESC") + (lambda () + (interactive) + (keyboard-escape-quit) + (winner-set guile-studio--layout))) + (kill-buffer "*scratch*") + + ;; Hide the cluttered Tools and Options menu items + (define-key global-map (vector 'menu-bar 'tools) 'undefined) + (define-key global-map (vector 'menu-bar 'options) 'undefined))) + +(add-hook 'after-init-hook 'global-company-mode) +(add-hook 'geiser-repl-mode-hook + (lambda () + (paren-face-mode 1) + (show-paren-mode 1))) +(add-hook 'scheme-mode-hook + (lambda () + (paren-face-mode 1) + (show-paren-mode 1) + (tab-line-mode 1) + (display-line-numbers-mode 1))) + +;; Don't show the Geiser menu in a Scheme buffer +(add-hook 'geiser-mode-hook + (lambda () + (define-key geiser-mode-map + (vector 'menu-bar 'geiserm) 'undefined))) + +;; Color theme +(require 'modus-themes) ; common code +(require 'modus-operandi-theme) ; light theme +(require 'modus-vivendi-theme) ; dark theme +(setq modus-themes-scale-headings t + modus-themes-variable-pitch-headings t + modus-themes-bold-constructs t + modus-themes-links 'no-underline) +(defun tweak-theme () + "Increase tab margins." + (let ((palette (modus-themes--active-theme))) + (set-face-attribute 'tab-line-tab nil + :box `(:line-width 8 + :color ,(cdr (assoc 'bg-tab-active palette)))) + (set-face-attribute 'tab-line-tab-inactive nil + :box `(:line-width 8 + :color ,(cdr (assoc 'bg-tab-inactive palette)))) + ;; Remove border around mode line + (set-face-attribute 'mode-line nil + :box nil) + (set-face-attribute 'mode-line-inactive nil + :box nil))) +(add-hook 'modus-themes-after-load-theme-hook 'tweak-theme) +(global-set-key (kbd "") 'modus-themes-toggle) +(load-theme 'modus-operandi t) +(tweak-theme) -- cgit v1.2.3