Require paren-face module.
[software/guile-studio.git] / guile-studio.el
1 ;; (defvar %guile-studio/prefix "@PREFIX@")
2 ;; (defvar %guile-studio/picture-language "@PICTURE_LANGUAGE@")
3 ;; (defvar %guile-studio/emacsdir "@EMACSDIR@")
4 ;; (defvar %guile-studio/guiledir "@GUILEDIR@")
5 ;; (defvar %guile-studio/guile-load-path "@GUILE_LOAD_PATH@")
6 ;; (defvar %guile-studio/guile-load-compiled-path "@GUILE_LOAD_COMPILED_PATH@")
7
8 (declare-function guix-emacs-autoload-packages "guix-emacs" ())
9 (declare-function geiser-repl--send "geiser-repl" (cmd &optional save-history))
10 (declare-function winner-conf "winner" ())
11 (declare-function winner-set "winner" (conf))
12
13 \f
14 (let ((guix-emacs.el
15 (expand-file-name
16 (concat %guile-studio/emacsdir "/share/emacs/site-lisp/guix-emacs.el"))))
17 (when (file-exists-p guix-emacs.el)
18 (load guix-emacs.el)))
19 (when (require 'guix-emacs nil t)
20 (guix-emacs-autoload-packages))
21
22 (setq-default line-spacing 2)
23 ;; Increase default font size
24 (set-face-attribute 'default nil :height 112)
25
26 (setq-default indent-tabs-mode nil)
27 (tool-bar-mode -1)
28 (menu-bar-mode 1)
29 (scroll-bar-mode -1)
30
31 (setq window-resize-pixelwise t)
32
33 ;; Show only buffers with the same major mode in the same tab line.
34 (require 'tab-line)
35 (setq tab-line-tabs-function 'tab-line-tabs-mode-buffers)
36 (setq tab-line-close-tab-function 'kill-buffer)
37
38 (require 'ivy)
39 (ivy-mode 1)
40 ;; Enter directory when hitting RET
41 (define-key ivy-minibuffer-map (kbd "<return>") 'ivy-alt-done)
42
43 (require 'info)
44 (setq Info-directory-list
45 (list (concat %guile-studio/prefix "/share/guile-studio/info/")
46 (concat %guile-studio/picture-language "/share/info/")
47 (concat %guile-studio/guiledir "/share/info/")))
48
49 ;; Use Ctrl-C/X/Z for copy, cut, paste
50 (require 'cua-base)
51 (cua-mode 1)
52 (require 'company)
53 (setq company-idle-delay 0.3)
54 (require 'elec-pair)
55 (electric-pair-mode 1)
56 (require 'scheme)
57 (require 'geiser)
58 (require 'paren-face)
59
60 ;; Add site-ccache directories to %load-compiled-path, and run the
61 ;; init routine. We don't use geiser-guile-init-file because that
62 ;; would lead to compilation messages in the REPL when Guile
63 ;; Studio is first started.
64 (defun guile-studio--geiser-guile--parameters (params)
65 (append (list "-C" (concat %guile-studio/prefix "/lib/guile/3.0/site-ccache/"))
66 (mapcan (lambda (dir) (list "-C" dir))
67 %guile-studio/guile-load-compiled-path)
68 params
69 (list "-e" "(@ (guile-studio-init) guile-studio-init)")))
70 (advice-add 'geiser-guile--parameters
71 :filter-return (function guile-studio--geiser-guile--parameters))
72 (setq geiser-guile-load-path
73 (mapcan (lambda (dir) (list "-C" dir))
74 %guile-studio/guile-load-path))
75
76 (setq geiser-autodoc-identifier-format "%s → %s")
77 (setq geiser-default-implementation 'guile
78 geiser-active-implementations '(guile)
79 geiser-mode-smart-tab-p t
80
81 initial-major-mode 'scheme-mode
82 inhibit-splash-screen t
83 confirm-kill-processes nil ; kill Geiser on exit
84 select-enable-clipboard t
85 select-enable-primary t
86 save-interprogram-paste-before-kill t
87 mouse-yank-at-point t
88 require-final-newline t
89 visible-bell nil
90 load-prefer-newer t)
91
92 (setq ring-bell-function
93 (lambda ()
94 (let ((orig-fg (face-foreground 'mode-line)))
95 (set-face-foreground 'mode-line "#F2804F")
96 (run-with-idle-timer 0.1 nil
97 (lambda (fg) (set-face-foreground 'mode-line fg))
98 orig-fg))))
99
100 ;; Hide the fact that this is Emacs
101 (modify-frame-parameters nil '((title . "Guile Studio")))
102
103 (defun menu-bar-read-guileref ()
104 "Display the Guile Reference manual in Info mode."
105 (interactive)
106 (info "guile"))
107 (defun menu-bar-read-pictref ()
108 "Display the Picture Language manual in Info mode."
109 (interactive)
110 (info "picture-language"))
111
112 (defun string-display-pixel-width (string)
113 "Calculate pixel width of STRING."
114 (with-temp-buffer
115 (with-silent-modifications
116 (setf (buffer-string) string))
117 (variable-pitch-mode 1)
118 (if (get-buffer-window (current-buffer))
119 (car (window-text-pixel-size nil (line-beginning-position) (point)))
120 (set-window-buffer nil (current-buffer))
121 (car (window-text-pixel-size nil (line-beginning-position) (point))))))
122
123 (defun right-align (string &optional center-p)
124 (let ((right-margin 3))
125 (concat
126 (propertize " " 'display
127 `(space :align-to
128 (- ,(if center-p 'center 'right)
129 (,(+ right-margin (string-display-pixel-width string))))))
130 string)))
131
132 ;; Adapted from fancy-splash-insert
133 (defun guile-studio-splash-insert (&rest args)
134 (let ((current-face nil))
135 (while args
136 (cond ((eq (car args) :face)
137 (setq args (cdr args) current-face (car args))
138 (if (functionp current-face)
139 (setq current-face (funcall current-face))))
140 ((eq (car args) :link)
141 (setq args (cdr args))
142 (let ((spec (car args)))
143 (if (functionp spec)
144 (setq spec (funcall spec)))
145 (insert-button (car spec)
146 'face (list 'link current-face)
147 'action (cadr spec)
148 'help-echo (concat "mouse-2, RET: "
149 (or (nth 2 spec)
150 "Follow this link"))
151 'follow-link t)))
152 (t
153 (insert (propertize (car args) 'face current-face))))
154 (setq args (cdr args)))))
155
156 (defvar about-guile-studio-text
157 `((:face variable-pitch
158 "Welcome to Guile Studio, an Emacs environment to play
159 with the "
160 :link ("GNU Guile programming language"
161 ,(lambda (_button) (browse-url "https://www.gnu.org/software/guile/"))
162 "Browse https://www.gnu.org/software/guile/")
163 " and its picture language.\n\n"
164
165 :face modus-theme-heading-1 "Manuals\n"
166 :face variable-pitch
167 " Learn all about Guile "
168 :link (,(right-align "View Guile Manual")
169 ,(lambda (_button) (menu-bar-read-guileref)))
170 "\n"
171 " How to draw pictures "
172 :link (,(right-align "View Picture Language Manual")
173 ,(lambda (_button) (menu-bar-read-pictref)))
174 "\n\n"
175 :face modus-theme-heading-1 "Common commands\n"
176 :face variable-pitch
177 " Save " ,(right-align "C-x C-s" t) "\t"
178 " Help " ,(right-align "C-h") "\n"
179
180 " Save as " ,(right-align "C-x C-w" t) "\t"
181 " Cancel " ,(right-align "C-g") "\n"
182
183 " Open a new file " ,(right-align "C-x C-f" t) "\t"
184 " Undo " ,(right-align "C-/") "\n"
185
186 " Close side window " ,(right-align "q" t) "\t"
187 " Close buffer " ,(right-align "C-x k") "\n"
188
189 " Browse directory " ,(right-align "C-x d" t) "\t"
190 " Quit " ,(right-align "C-x C-c") "\n"
191 "\n"
192 "Access a context-specific menu by right-clicking.\n"
193 "Toggle between dark and light mode with F5."
194 "\n")))
195
196 (defun about-guile-studio ()
197 "Display the Guile Studio about buffer."
198 (interactive)
199 (let ((splash-buffer (get-buffer-create "*Guile Studio*")))
200 (with-current-buffer
201 splash-buffer
202 (let ((inhibit-read-only t))
203 (erase-buffer)
204 (setq default-directory command-line-default-directory)
205 (make-local-variable 'startup-screen-inhibit-startup-screen)
206 (let* ((image-file (concat %guile-studio/prefix "/share/logo.svg"))
207 (img (create-image image-file))
208 (image-width (and img (car (image-size img))))
209 (window-width (window-width)))
210 (when img
211 (insert "\n")
212 (when (> window-width image-width)
213 ;; Center the image in the window.
214 (insert (propertize " " 'display
215 `(space :align-to (+ center (-0.5 . ,img)))))
216
217 ;; Insert the image with a help-echo and a link.
218 (make-button (prog1 (point) (insert-image img)) (point)
219 'face 'default
220 'help-echo "mouse-2, RET: Browse https://www.gnu.org/software/guile"
221 'action (lambda (_button) (browse-url "https://www.gnu.org/software/guile"))
222 'follow-link t)
223 (insert "\n\n"))))
224 (dolist (text about-guile-studio-text)
225 (apply (function guile-studio-splash-insert) text)
226 (insert "\n")))
227 (use-local-map splash-screen-keymap)
228 (setq buffer-read-only t)
229 (set-buffer-modified-p nil)
230 (if (and view-read-only (not view-mode))
231 (view-mode-enter nil 'kill-buffer))
232 (goto-char (point-min))
233 (forward-line 4))
234 (pop-to-buffer splash-buffer 'display-buffer-in-side-window)))
235
236 ;; Unclutter help menu.
237 (require 'menu-bar)
238 (setq menu-bar-help-menu
239 (let ((menu (make-sparse-keymap "Help")))
240 (bindings--define-key menu (vector 'about-gnu-project)
241 '(menu-item "About GNU" describe-gnu-project
242 :help "About the GNU System, GNU Project, and GNU/Linux"))
243 (bindings--define-key menu (vector 'about-guile-studio)
244 '(menu-item "About Guile Studio" about-guile-studio
245 :help "About this program"))
246 (bindings--define-key menu (vector 'sep2)
247 menu-bar-separator)
248 (bindings--define-key menu (vector 'other-manuals)
249 '(menu-item "All Other Manuals (Info)" Info-directory
250 :help "Read any of the installed manuals"))
251 (bindings--define-key menu (vector 'guile-reference)
252 '(menu-item "Guile Reference" menu-bar-read-guileref
253 :help "Read the Guile Reference manual"))
254 menu))
255 (bindings--define-key global-map (vector 'menu-bar 'help-menu)
256 (cons (purecopy "Help") menu-bar-help-menu))
257
258 ;; Unclutter File menu
259 (setq menu-bar-file-menu
260 (let ((menu (make-sparse-keymap "File")))
261 (bindings--define-key menu (vector 'exit-emacs)
262 '(menu-item "Quit" save-buffers-kill-terminal
263 :help "Save unsaved buffers, then exit"))
264 (bindings--define-key menu (vector 'sep-exit)
265 menu-bar-separator)
266 (bindings--define-key menu (vector 'revert-buffer)
267 '(menu-item "Revert Buffer" revert-buffer
268 :enable
269 (or
270 (not
271 (eq revert-buffer-function 'revert-buffer--default))
272 (not
273 (eq revert-buffer-insert-file-contents-function
274 'revert-buffer-insert-file-contents--default-function))
275 (and buffer-file-number
276 (not
277 (verify-visited-file-modtime
278 (current-buffer)))))
279 :help "Re-read current buffer from its file"))
280 (bindings--define-key menu (vector 'write-file)
281 '(menu-item "Save As..." write-file
282 :enable menu-bar-menu-frame-live-and-visible-p
283 :help "Write current buffer to another file"))
284 (bindings--define-key menu (vector 'save-buffer)
285 '(menu-item "Save" save-buffer :enable
286 (and (buffer-modified-p)
287 (buffer-file-name))
288 :help "Save current buffer to its file"))
289 (bindings--define-key menu (vector 'sep-save)
290 menu-bar-separator)
291 (bindings--define-key menu (vector 'kill-buffer)
292 '(menu-item "Close" kill-this-buffer :enable
293 (kill-this-buffer-enabled-p)
294 :help "Discard (kill) current buffer"))
295
296 (bindings--define-key menu (vector 'dired)
297 '(menu-item "Open File..." dired-sidebar-show-sidebar
298 :help "Show the directory browser in a side bar"))
299 (bindings--define-key menu (vector 'new-file)
300 '(menu-item "New File" (lambda ()
301 (interactive)
302 (select-window
303 (get-window-with-predicate
304 (lambda (window)
305 (window-parameter window 'guile-studio/edit))))
306 (find-file "untitled.scm"))
307 :help "Create a new file buffer"))
308 menu))
309 (bindings--define-key global-map (vector 'menu-bar 'file)
310 (cons (purecopy "File") menu-bar-file-menu))
311
312 ;; Unclutter Edit menu
313 (define-key menu-bar-edit-menu (vector 'goto) nil)
314 (define-key menu-bar-edit-menu (vector 'bookmark) nil)
315 (define-key menu-bar-edit-menu (vector 'separator-bookmark) nil)
316 (define-key menu-bar-edit-menu (vector 'fill) nil)
317 (define-key menu-bar-edit-menu (vector 'props) nil)
318
319 (define-key menu-bar-edit-menu (vector 'replace 'tags-repl) nil)
320 (define-key menu-bar-edit-menu (vector 'replace 'tags-repl-continue) nil)
321 (define-key menu-bar-edit-menu (vector 'search)
322 '(menu-item "Search..." isearch-forward-regexp
323 :help "Incrementally search for a regular expression"))
324
325 ;; Check syntax on the fly
326 (require 'flycheck)
327 (require 'flycheck-guile)
328 (global-flycheck-mode 1)
329
330 ;; Remember location in buffers
331 (require 'saveplace)
332 (setq-default save-place t)
333
334 ;; Right side window
335 (defvar popup-right-side-windows
336 (rx (or "*Guile Studio*"
337 "*Geiser documentation*"
338 (seq "*Help" (* anychar) "*")
339 "*info*")))
340 (add-to-list 'display-buffer-alist
341 `(,popup-right-side-windows
342 (display-buffer-reuse-window
343 display-buffer-in-side-window)
344 (inhibit-same-window . t)
345 (side . right)
346 (slot . 0)
347 (preserve-size . (t . t))
348 (window-width . 80)
349 (window-height . 1.0)))
350
351 ;; Bottom side window
352 (defvar popup-bottom-windows
353 (rx (or "*Flycheck*"
354 "*Flymake*"
355 "*Backtrace*"
356 "*Warnings*"
357 "*Compile-Log*"
358 "*Messages*"
359 (seq (* anychar) "*Completions" (* anychar)))))
360 (add-to-list 'display-buffer-alist
361 `(,popup-bottom-windows
362 (display-buffer-reuse-window
363 display-buffer-in-side-window)
364 (inhibit-same-window . t)
365 (side . bottom)
366 (slot . 0)
367 (preserve-size . (t . t))
368 (window-height . 0.16)))
369
370 (defvar bottom-windows
371 (rx (or (seq "* Guile REPL *" (* anychar))
372 "*Geiser dbg*")))
373 (add-to-list 'display-buffer-alist
374 `(,bottom-windows
375 (display-buffer-reuse-window
376 display-buffer-at-bottom)
377 (window-height . 10)))
378
379 (require 'dired-sidebar)
380 (global-set-key (kbd "C-x d") 'dired-sidebar-toggle-sidebar)
381 ;; Delete dired window on "q"
382 (define-key dired-mode-map (kbd "q") 'delete-window)
383 (setq dired-sidebar-one-instance-p t
384 dired-sidebar-close-sidebar-on-file-open t)
385
386 ;; Mode line settings
387 (require 'doom-modeline)
388 (setq doom-modeline-buffer-encoding nil)
389
390 ;; Remove incorrect help echo from buffer name
391 (require 'doom-modeline-segments)
392 (doom-modeline-def-segment buffer-info
393 (concat
394 (doom-modeline-spc)
395 (doom-modeline--buffer-mode-icon)
396 (doom-modeline--buffer-state-icon)
397 (propertize "%b" 'face 'doom-modeline-buffer-file)))
398 (doom-modeline-mode 1)
399
400 ;; Stop using the minibuffer when leaving it
401 (defun stop-using-minibuffer ()
402 "kill the minibuffer"
403 (when (and (>= (recursion-depth) 1) (active-minibuffer-window))
404 (abort-recursive-edit)))
405 (add-hook 'mouse-leave-buffer-hook 'stop-using-minibuffer)
406
407 (require 'uniquify)
408 (setq uniquify-buffer-name-style 'forward)
409
410 ;; Add close button for opened buffers.
411 (require 'mouse)
412 (defconst my-mode-line-map
413 (let ((map (make-sparse-keymap)))
414 (define-key map (vector 'mode-line 'mouse-1)
415 'mouse-delete-window)
416 map))
417 (setq global-mode-string
418 (append global-mode-string
419 '(:eval (if (window-dedicated-p (selected-window))
420 ""
421 (propertize "[⨯]"
422 'local-map my-mode-line-map
423 'mouse-face 'mode-line-highlight)))))
424 (global-unset-key (vector 'mode-line 'mouse-2)) ; 'mouse-delete-other-windows
425 (global-unset-key (vector 'mode-line 'mouse-3)) ; 'mouse-delete-window
426
427 ;; Don't switch buffers when clicking on the name.
428 (define-key mode-line-buffer-identification-keymap (vector 'mode-line 'mouse-1) nil)
429 (define-key mode-line-buffer-identification-keymap (vector 'mode-line 'mouse-3) nil)
430
431 ;; Context menu on right click.
432 (defun context-menu ()
433 (let ((menu (make-sparse-keymap)))
434 (pcase major-mode
435 ('geiser-repl-mode
436 (define-key menu (vector 'insert-image)
437 '("Insert image" . geiser--guile-picture-language--pict-from-file))
438 menu)
439 ('scheme-mode
440 (define-key menu (vector 'switch-to-repl)
441 '("Switch to REPL" . switch-to-geiser))
442 (define-key menu (vector 'eval-buffer)
443 '("Evaluate buffer" . geiser-eval-buffer))
444 (define-key menu (vector 'lookup-documentation)
445 '("Show documentation". geiser-doc-symbol-at-point))
446 menu)
447 (_
448 (mouse-menu-major-mode-map)))))
449
450 (global-set-key (vector 'mouse-3)
451 (lambda (event)
452 (interactive "e")
453 (mouse-set-point event)
454 (popup-menu (context-menu))))
455
456 (defun geiser--guile-picture-language--pict-from-file ()
457 (interactive)
458 (let ((file (read-file-name "Insert image: " nil nil t nil
459 (lambda (name)
460 (or (string-suffix-p ".svg" name t)
461 (string-suffix-p ".png" name t))))))
462 (geiser-repl--send
463 (concat "(pict-from-file \""
464 file
465 "\")"))))
466
467 (add-to-list 'initial-frame-alist
468 '(fullscreen . maximized))
469
470 (add-hook 'emacs-startup-hook
471 (lambda ()
472 (require 'winner)
473 (winner-mode 1)
474 (let ((buf (generate-new-buffer "untitled.scm")))
475 (with-current-buffer buf
476 (switch-to-buffer buf nil t)
477 (set-window-dedicated-p (selected-window) nil)
478 (set-window-parameter (selected-window) 'guile-studio/edit t)
479 (funcall (and initial-major-mode))
480 (insert ";;; Welcome to Guile Studio!\n")
481 (insert ";;; Type your Guile program here and evaluate it.\n\n")
482 (setq buffer-offer-save t)
483
484 (switch-to-geiser)
485 (set-window-dedicated-p (selected-window) t)
486 (call-interactively 'about-guile-studio))
487
488 ;; This is necessary to show the REPL prompt after
489 ;; displaying the side window.
490 (pop-to-buffer "* Guile REPL *"))
491
492 ;; Always restore default layout
493 (defvar guile-studio--layout (winner-conf))
494 (define-key global-map (kbd "ESC ESC ESC")
495 (lambda ()
496 (interactive)
497 (keyboard-escape-quit)
498 (winner-set guile-studio--layout)))
499 (kill-buffer "*scratch*")
500
501 ;; Hide the cluttered Tools and Options menu items
502 (define-key global-map (vector 'menu-bar 'tools) 'undefined)
503 (define-key global-map (vector 'menu-bar 'options) 'undefined)))
504
505 (add-hook 'after-init-hook 'global-company-mode)
506 (add-hook 'geiser-repl-mode-hook
507 (lambda ()
508 (paren-face-mode 1)
509 (show-paren-mode 1)))
510 (add-hook 'scheme-mode-hook
511 (lambda ()
512 (paren-face-mode 1)
513 (show-paren-mode 1)
514 (tab-line-mode 1)
515 (display-line-numbers-mode 1)))
516
517 ;; Don't show the Geiser menu in a Scheme buffer
518 (add-hook 'geiser-mode-hook
519 (lambda ()
520 (define-key geiser-mode-map
521 (vector 'menu-bar 'geiserm) 'undefined)))
522
523 ;; Color theme
524 (require 'modus-themes) ; common code
525 (require 'modus-operandi-theme) ; light theme
526 (require 'modus-vivendi-theme) ; dark theme
527 (setq modus-themes-scale-headings t
528 modus-themes-variable-pitch-headings t
529 modus-themes-bold-constructs t
530 modus-themes-links 'no-underline)
531 (defun tweak-theme ()
532 "Increase tab margins."
533 (let ((palette (modus-themes--active-theme)))
534 (set-face-attribute 'tab-line-tab nil
535 :box `(:line-width 8
536 :color ,(cdr (assoc 'bg-tab-active palette))))
537 (set-face-attribute 'tab-line-tab-inactive nil
538 :box `(:line-width 8
539 :color ,(cdr (assoc 'bg-tab-inactive palette))))
540 ;; Remove border around mode line
541 (set-face-attribute 'mode-line nil
542 :box nil)
543 (set-face-attribute 'mode-line-inactive nil
544 :box nil)))
545 (add-hook 'modus-themes-after-load-theme-hook 'tweak-theme)
546 (global-set-key (kbd "<f5>") 'modus-themes-toggle)
547 (load-theme 'modus-operandi t)
548 (tweak-theme)