Use flycheck-guile package.
[software/guile-studio.git] / guile-studio-configure.scm
1 (use-modules (ice-9 pretty-print)
2 (ice-9 match)
3 (ice-9 ftw)
4 (srfi srfi-1)
5 (srfi srfi-26))
6
7 (define (generate-configuration prefix emacsdir guiledir picture-language icons emacs-package-dirs)
8 `(progn
9 (let ((guix-emacs.el
10 (expand-file-name
11 ,(string-append emacsdir "/share/emacs/site-lisp/guix-emacs.el"))))
12 (when (file-exists-p guix-emacs.el)
13 (load guix-emacs.el)))
14 (when (require 'guix-emacs nil t)
15 (guix-emacs-autoload-packages))
16
17 (setq-default indent-tabs-mode nil)
18 (tool-bar-mode 1)
19 (menu-bar-mode 1)
20 (set-scroll-bar-mode 'right)
21
22 (require 'info)
23 (setq Info-directory-list
24 '(,(string-append prefix "/share/guile-studio/info/")
25 ,(string-append picture-language "/share/info/")
26 ,(string-append guiledir "/share/info/")))
27
28 ;; Use Ctrl-C/X/Z for copy, cut, paste
29 (require 'cua-base)
30 (cua-mode 1)
31 (require 'company)
32 (setq company-idle-delay 0.3)
33 (require 'elec-pair)
34 (electric-pair-mode 1)
35 (require 'scheme)
36 (require 'geiser)
37
38 ;; Add site-ccache directories to %load-compiled-path, and run the
39 ;; init routine. We don't use geiser-guile-init-file because that
40 ;; would lead to compilation messages in the REPL when Guile
41 ;; Studio is first started.
42 (defun guile-studio--geiser-guile--parameters (params)
43 (append (list "-C" ,(string-append prefix "/lib/guile/3.0/site-ccache/"))
44 (list "-C" ,(string-append picture-language "/lib/guile/3.0/site-ccache/"))
45 params
46 (list "-e" "(@ (guile-studio-init) guile-studio-init)")))
47 (advice-add 'geiser-guile--parameters
48 :filter-return (function guile-studio--geiser-guile--parameters))
49 (setq geiser-guile-load-path
50 '(,(string-append picture-language
51 "/share/guile/site/3.0/")))
52
53 (setq geiser-autodoc-identifier-format "%s → %s")
54 (setq geiser-default-implementation 'guile
55 geiser-active-implementations '(guile)
56
57 initial-major-mode 'scheme-mode
58 inhibit-splash-screen t
59 confirm-kill-processes nil ; kill Geiser on exit
60 x-select-enable-clipboard t
61 x-select-enable-primary t
62 save-interprogram-paste-before-kill t
63 apropos-do-all t
64 mouse-yank-at-point t
65 require-final-newline t
66 visible-bell t
67 load-prefer-newer t
68 save-place-file (concat user-emacs-directory "places"))
69
70 ;; Hide the fact that this is Emacs
71 (modify-frame-parameters nil '((title . "Guile Studio")))
72
73 ;; Unclutter help menu.
74 (require 'menu-bar)
75 (defun menu-bar-read-guileref ()
76 "Display the Guile Reference manual in Info mode."
77 (interactive)
78 (info "guile"))
79 (defvar about-guile-studio-text
80 `((:face (variable-pitch font-lock-comment-face)
81 "Welcome to Guile Studio, an Emacs environment to play
82 with the "
83 :link ("GNU Guile programming language"
84 ,(lambda (_button) (browse-url "https://www.gnu.org/software/guile/"))
85 "Browse https://www.gnu.org/software/guile/")
86 " and its picture language.\n\n"
87
88 :face variable-pitch
89 :link ("View Guile Manual" ,(lambda (_button) (menu-bar-read-guileref)))
90 "\tView the Guile manual using Info\n"
91 "\n")))
92
93 (defun about-guile-studio ()
94 "Display the Guile Studio about buffer."
95 (interactive)
96 (let ((splash-buffer (get-buffer-create "*Guile Studio*")))
97 (with-current-buffer
98 splash-buffer
99 (let ((inhibit-read-only t))
100 (erase-buffer)
101 (setq default-directory command-line-default-directory)
102 (make-local-variable 'startup-screen-inhibit-startup-screen)
103 (let* ((image-file ,(string-append prefix "/share/logo.svg"))
104 (img (create-image image-file))
105 (image-width (and img (car (image-size img))))
106 (window-width (window-width)))
107 (when img
108 (when (> window-width image-width)
109 ;; Center the image in the window.
110 (insert (propertize " " 'display
111 `(space :align-to (+ center (-0.5 . ,img)))))
112
113 ;; Insert the image with a help-echo and a link.
114 (make-button (prog1 (point) (insert-image img)) (point)
115 'face 'default
116 'help-echo "mouse-2, RET: Browse https://www.gnu.org/software/guile"
117 'action (lambda (_button) (browse-url "https://www.gnu.org/software/guile"))
118 'follow-link t)
119 (insert "\n\n"))))
120 (dolist (text about-guile-studio-text)
121 (apply (function fancy-splash-insert) text)
122 (insert "\n")))
123 (use-local-map splash-screen-keymap)
124 (setq buffer-read-only t)
125 (set-buffer-modified-p nil)
126 (if (and view-read-only (not view-mode))
127 (view-mode-enter nil 'kill-buffer))
128 (goto-char (point-min))
129 (forward-line 4))
130 (switch-to-buffer splash-buffer)))
131
132 (setq menu-bar-help-menu
133 (let ((menu (make-sparse-keymap "Help")))
134 (bindings--define-key menu (vector 'about-gnu-project)
135 '(menu-item "About GNU" describe-gnu-project
136 :help "About the GNU System, GNU Project, and GNU/Linux"))
137 (bindings--define-key menu (vector 'about-guile-studio)
138 '(menu-item "About Guile Studio" about-guile-studio
139 :help "About this program"))
140 (bindings--define-key menu (vector 'sep2)
141 menu-bar-separator)
142 (bindings--define-key menu (vector 'other-manuals)
143 '(menu-item "All Other Manuals (Info)" Info-directory
144 :help "Read any of the installed manuals"))
145 (bindings--define-key menu (vector 'guile-reference)
146 '(menu-item "Guile Reference" menu-bar-read-guileref
147 :help "Read the Guile Reference manual"))
148 menu))
149 (bindings--define-key global-map (vector 'menu-bar 'help-menu)
150 (cons (purecopy "Help") menu-bar-help-menu))
151
152 ;; Unclutter File menu
153 (setq menu-bar-file-menu
154 (let ((menu (make-sparse-keymap "File")))
155 (bindings--define-key menu (vector 'exit-emacs)
156 '(menu-item "Quit" save-buffers-kill-terminal
157 :help "Save unsaved buffers, then exit"))
158 (bindings--define-key menu (vector 'sep-exit)
159 menu-bar-separator)
160 (bindings--define-key menu (vector 'revert-buffer)
161 '(menu-item "Revert Buffer" revert-buffer
162 :enable
163 (or
164 (not
165 (eq revert-buffer-function 'revert-buffer--default))
166 (not
167 (eq revert-buffer-insert-file-contents-function
168 'revert-buffer-insert-file-contents--default-function))
169 (and buffer-file-number
170 (not
171 (verify-visited-file-modtime
172 (current-buffer)))))
173 :help "Re-read current buffer from its file"))
174 (bindings--define-key menu (vector 'write-file)
175 '(menu-item "Save As..." write-file
176 :enable menu-bar-menu-frame-live-and-visible-p
177 :help "Write current buffer to another file"))
178 (bindings--define-key menu (vector 'save-buffer)
179 '(menu-item "Save" save-buffer :enable
180 (and (buffer-modified-p)
181 (buffer-file-name))
182 :help "Save current buffer to its file"))
183 (bindings--define-key menu (vector 'sep-save)
184 menu-bar-separator)
185 (bindings--define-key menu (vector 'kill-buffer)
186 '(menu-item "Close" kill-this-buffer :enable
187 (kill-this-buffer-enabled-p)
188 :help "Discard (kill) current buffer"))
189
190 (bindings--define-key menu (vector 'dired)
191 '(menu-item "Open Directory..." dired
192 :help "Read a directory, to operate on its files"))
193 (bindings--define-key menu (vector 'open-file)
194 '(menu-item "Open File..." menu-find-file-existing
195 :help "Read an existing file into an Emacs buffer"))
196 (bindings--define-key menu (vector 'new-file)
197 '(menu-item "Visit New File..." find-file
198 :enable menu-bar-non-minibuffer-window-p
199 :help "Specify a new file's name, to edit the file"))
200 menu))
201 (bindings--define-key global-map (vector 'menu-bar 'file)
202 (cons (purecopy "File") menu-bar-file-menu))
203
204 ;; Check syntax on the fly
205 (require 'flycheck)
206 (require 'flycheck-guile)
207 (global-flycheck-mode 1)
208
209 ;; Remember location in buffers
210 (require 'saveplace)
211 (setq-default save-place t)
212
213 ;; Mode line settings
214 (require 'smart-mode-line)
215 (setq sml/no-confirm-load-theme t)
216 (setq sml/theme 'respectful)
217 (setq sml/position-percentage-format nil)
218 (setq sml/mule-info nil)
219 (setq sml/read-only-char
220 (propertize "R" 'display
221 (create-image "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"20\" height=\"14\" viewBox=\"0 0 448 612\">\
222 <path fill=\"currentColor\" \
223 d=\"M400 224h-24v-72C376 68.2 307.8 0 224 0S72 68.2 72 \
224 152v72H48c-26.5 0-48 21.5-48 48v192c0 26.5 21.5 48 48 48h352c26.5 \
225 0 48-21.5 48-48V272c0-26.5-21.5-48-48-48zm-104 0H152v-72c0-39.7 \
226 32.3-72 72-72s72 32.3 72 72v72z\"></path></svg>" 'svg t)))
227 (sml/setup)
228 (setq rm-whitelist '("Paredit"))
229
230 (require 'uniquify)
231 (setq uniquify-buffer-name-style 'forward)
232
233 ;; Add close button for opened buffers.
234 (require 'mouse)
235 (defconst my-mode-line-map
236 (let ((map (make-sparse-keymap)))
237 (define-key map (vector 'mode-line 'mouse-1)
238 'mouse-delete-window)
239 map))
240 (setq global-mode-string
241 (append global-mode-string
242 '(:eval (if (window-dedicated-p (selected-window))
243 ""
244 (propertize "[⨯]"
245 'local-map my-mode-line-map
246 'mouse-face 'mode-line-highlight)))))
247 (global-unset-key (vector 'mode-line 'mouse-2)) ; 'mouse-delete-other-windows
248 (global-unset-key (vector 'mode-line 'mouse-3)) ; 'mouse-delete-window
249
250
251 (defun geiser--guile-picture-language--pict-from-file ()
252 (interactive)
253 (let ((file (read-file-name "Insert image: " nil nil t nil
254 (lambda (name)
255 (or (string-suffix-p ".svg" name t)
256 (string-suffix-p ".png" name t))))))
257 (geiser-repl--send
258 (concat "(pict-from-file \""
259 file
260 "\")"))))
261
262 (defvar geiser-repl-tool-bar-map (make-sparse-keymap))
263 (define-key geiser-repl-tool-bar-map (vector 'insert-image)
264 '(menu-item " Insert image" geiser--guile-picture-language--pict-from-file
265 :image
266 (image :type png
267 :file ,(string-append icons "/24x24/legacy/insert-image.png"))
268 :help "Insert image..."))
269
270 (defvar scheme-tool-bar-map (make-sparse-keymap))
271 (define-key scheme-tool-bar-map (vector 'eval-buffer)
272 '(menu-item " Evaluate" geiser-eval-buffer
273 :image
274 (image :type png
275 :file ,(string-append icons "/24x24/legacy/media-playback-start.png"))
276 :help "Evaluate buffer..."))
277 (define-key scheme-tool-bar-map (vector 'lookup-documentation)
278 '(menu-item " Documentation" geiser-doc-symbol-at-point
279 :image
280 (image :type png
281 :file ,(string-append icons "/24x24/legacy/help-faq.png"))
282 :help "Show documentation for the current symbol"))
283
284 (add-hook 'emacs-startup-hook
285 (lambda ()
286 (let ((buf (generate-new-buffer "untitled.scm")))
287 (switch-to-buffer buf nil t)
288 (funcall (and initial-major-mode))
289 (setq buffer-offer-save t)
290 (delete-other-windows)
291 (set-window-dedicated-p (selected-window) t))
292 (run-guile)
293 (set-window-dedicated-p (selected-window) t)
294 ;; Hide the cluttered Tools and Options menu items
295 (define-key global-map (vector 'menu-bar 'tools) 'undefined)
296 (define-key global-map (vector 'menu-bar 'options) 'undefined)
297
298 ;; Prefer horizontal splits
299 (setq split-height-threshold nil)
300 (setq split-width-threshold 80)))
301
302 (add-hook 'after-init-hook 'global-company-mode)
303 (add-hook 'geiser-repl-mode-hook
304 (lambda ()
305 (paren-face-mode 1)
306 (show-paren-mode 1)
307 (unless (local-variable-p 'tool-bar-map)
308 (set (make-local-variable 'tool-bar-map)
309 geiser-repl-tool-bar-map))))
310 (add-hook 'scheme-mode-hook
311 (lambda ()
312 (paren-face-mode 1)
313 (show-paren-mode 1)
314 (unless (local-variable-p 'tool-bar-map)
315 (set (make-local-variable 'tool-bar-map)
316 scheme-tool-bar-map))))
317
318 ;; Don't show the Geiser menu in a Scheme buffer
319 (add-hook 'geiser-mode-hook
320 (lambda ()
321 (define-key geiser-mode-map
322 (vector 'menu-bar 'geiserm) 'undefined)))
323 (load-theme 'adwaita t)))
324
325 (define (make-guile-studio-wrapper prefix share emacsdir emacs-package-dirs)
326 (let ((wrapper (string-append prefix "/bin/guile-studio")))
327 (with-output-to-file wrapper
328 (lambda ()
329 (format #t "#!/bin/sh
330 EMACSLOADPATH=~a:
331 exec ~a/bin/emacs --no-site-file --no-site-lisp --no-x-resources --no-init-file --load ~a/guile-studio.el
332 "
333 (string-join
334 (map (cut string-append <> "/share/emacs/site-lisp")
335 emacs-package-dirs) ":")
336 emacsdir share)))
337 (chmod wrapper #o555)))
338
339 (define (main)
340 (define (info-file? file)
341 (or (string-suffix? ".info" file)
342 (string-suffix? ".info.gz" file)))
343 (define (info-files top)
344 (let ((infodir (string-append top "/share/info")))
345 (map (cut string-append infodir "/" <>)
346 (or (scandir infodir info-file?) '()))))
347 (match (command-line)
348 ((_ prefix emacsdir guiledir picture-language icons . emacs-package-dirs)
349 (let* ((share (string-append prefix "/share"))
350 (datadir (string-append share "/guile-studio"))
351 (infodir (string-append datadir "/info")))
352 ;; Generate Info directory
353 (mkdir datadir)
354 (mkdir infodir)
355 (for-each
356 (lambda (info)
357 (system* "install-info" "--debug" info
358 (string-append infodir "/dir")))
359 (append-map info-files (list picture-language guiledir)))
360
361 ;; Generate Emacs startup file
362 (with-output-to-file (string-append share "/guile-studio.el")
363 (lambda ()
364 (pretty-print
365 (generate-configuration prefix
366 emacsdir
367 guiledir
368 picture-language
369 icons
370 emacs-package-dirs)
371 #:display? #f)))
372
373 ;; CC-BY-SA 4.0 Luis Felipe López Acevedo (aka sirgazil)
374 (copy-file "logo.svg"
375 (string-append share "/logo.svg"))
376
377 (make-guile-studio-wrapper prefix share emacsdir emacs-package-dirs)
378
379 ;; Generate Guile init file.
380 (with-output-to-file (string-append share "/guile-studio-init.scm")
381 (lambda ()
382 (format #t "~s" '(begin
383 (define-module (guile-studio-init))
384 (define-public (guile-studio-init . any)
385 (set! (@@ (system repl common) repl-welcome) (const #t))
386 (use-modules (pict)))))))
387 (compile-file (string-append share "/guile-studio-init.scm")
388 #:output-file
389 (string-append prefix "/lib/guile/3.0/site-ccache/"
390 "/guile-studio-init.go")))
391 #t)
392 ((script . _)
393 (format (current-error-port)
394 "usage: ~a prefix emacsdir picture-language icons emacs-package-dirs ...\n"
395 script))))
396
397 (main)