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. --- Makefile | 1 + guile-studio-configure.scm | 594 ++++----------------------------------------- guile-studio.el | 544 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 587 insertions(+), 552 deletions(-) create mode 100644 guile-studio.el diff --git a/Makefile b/Makefile index 7ddfe48..1bb7570 100644 --- a/Makefile +++ b/Makefile @@ -1,6 +1,7 @@ VERSION = 0.1.0 SOURCES = \ + guile-studio.el \ guile-studio-configure.scm \ logo.svg \ Makefile \ diff --git a/guile-studio-configure.scm b/guile-studio-configure.scm index f337283..f5a2cc8 100644 --- a/guile-studio-configure.scm +++ b/guile-studio-configure.scm @@ -1,550 +1,10 @@ -(use-modules (ice-9 pretty-print) - (ice-9 match) +(use-modules (ice-9 match) (ice-9 ftw) + (ice-9 binary-ports) + (rnrs bytevectors) (srfi srfi-1) (srfi srfi-26)) -(define (generate-configuration prefix emacsdir guiledir picture-language emacs-package-dirs) - `(progn - (let ((guix-emacs.el - (expand-file-name - ,(string-append 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 - '(,(string-append prefix "/share/guile-studio/info/") - ,(string-append picture-language "/share/info/") - ,(string-append 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" ,(string-append prefix "/lib/guile/3.0/site-ccache/")) - ,@(map (lambda (dir) (list 'list "-C" dir)) - (string-tokenize (getenv "GUILE_LOAD_COMPILED_PATH") - (char-set-complement (char-set #\:)))) - 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 - (append ,@(map (lambda (dir) (list 'list "-C" dir)) - (string-tokenize (getenv "GUILE_LOAD_PATH") - (char-set-complement (char-set #\:)))))) - - (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 ,(string-append 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))) - (define (make-guile-studio-wrapper prefix share emacsdir emacs-package-dirs) (let ((wrapper (string-append prefix "/bin/guile-studio"))) (with-output-to-file wrapper @@ -559,6 +19,18 @@ exec ~a/bin/emacs -mm --no-site-file --no-site-lisp --no-x-resources --no-init-f emacsdir share))) (chmod wrapper #o555))) +(define* (dump-port in out #:key (buffer-size 16384)) + (define buffer + (make-bytevector buffer-size)) + + (define (loop bytes) + (or (eof-object? bytes) + (begin + (put-bytevector out buffer 0 bytes) + (loop (get-bytevector-n! in buffer 0 buffer-size))))) + + (loop (get-bytevector-n! in buffer 0 buffer-size))) + (define (main) (define (info-file? file) (or (string-suffix? ".info" file) @@ -582,15 +54,33 @@ exec ~a/bin/emacs -mm --no-site-file --no-site-lisp --no-x-resources --no-init-f (append-map info-files (list picture-language guiledir))) ;; Generate Emacs startup file - (with-output-to-file (string-append share "/guile-studio.el") - (lambda () - (pretty-print - (generate-configuration prefix - emacsdir - guiledir - picture-language - emacs-package-dirs) - #:display? #f))) + (call-with-output-file (string-append share "/guile-studio.el") + (lambda (out) + ;; Generate global variables at the top. + (write `(defvar %guile-studio/guile-load-compiled-path + ',(parse-path (getenv "GUILE_LOAD_COMPILED_PATH"))) + out) + (write `(defvar %guile-studio/guile-load-path + ',(parse-path (getenv "GUILE_LOAD_PATH"))) + out) + (write `(defvar %guile-studio/prefix ,prefix) out) + (write `(defvar %guile-studio/picture-language ,picture-language) out) + (write `(defvar %guile-studio/emacsdir ,emacsdir) out) + (write `(defvar %guile-studio/guiledir ,guiledir) out) + ;; Paste the contents of guile-studio.el here + (call-with-input-file "guile-studio.el" + (lambda (in) + (dump-port in out))))) + + (setenv "EMACSLOADPATH" + (string-join + (map (cut string-append <> "/share/emacs/site-lisp") + emacs-package-dirs) ":" 'suffix)) + (system* "emacs" "--quick" "--batch" + (format #f "--eval=~a" + `(progn + (setq byte-compile-debug t) + (byte-compile-file ,(string-append "\"" share "/guile-studio.el\""))))) ;; CC-BY-SA 4.0 Luis Felipe López Acevedo (aka sirgazil) (copy-file "logo.svg" 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