Add support for flycheck.
[software/guile-studio.git] / guile-studio-configure.scm
1 (use-modules (ice-9 pretty-print)
2 (ice-9 match))
3
4 (define (generate-configuration prefix emacsdir picture-language icons emacs-package-dirs)
5 `(progn
6 (load (expand-file-name
7 ,(string-append emacsdir "/share/emacs/site-lisp/guix-emacs.el")))
8 (when (require 'guix-emacs nil t)
9 (guix-emacs-autoload-packages ,@emacs-package-dirs))
10
11 (setq-default indent-tabs-mode nil)
12 (tool-bar-mode 1)
13 (menu-bar-mode 1)
14 (set-scroll-bar-mode 'right)
15
16 ;; Use Ctrl-C/X/Z for copy, cut, paste
17 (require 'cua-base)
18 (cua-mode 1)
19 (require 'company)
20 (setq company-idle-delay 0.3)
21 (require 'elec-pair)
22 (electric-pair-mode 1)
23 (require 'scheme)
24 (require 'geiser)
25 (setq geiser-guile-load-path
26 '(,(string-append picture-language
27 "/share/guile/site/2.2/")
28 ,(string-append picture-language
29 "/lib/guile/2.2/site-ccache/")))
30 (setq geiser-guile-init-file ,(string-append prefix
31 "/share/guile-studio-init"))
32 (setq geiser-autodoc-identifier-format "%s ~ %s")
33 (setq geiser-default-implementation 'guile
34 initial-major-mode 'scheme-mode
35 inhibit-splash-screen t
36 x-select-enable-clipboard t
37 x-select-enable-primary t
38 save-interprogram-paste-before-kill t
39 apropos-do-all t
40 mouse-yank-at-point t
41 require-final-newline t
42 visible-bell t
43 load-prefer-newer t
44 save-place-file (concat user-emacs-directory "places"))
45
46 ;; Hide the fact that this is Emacs
47 (modify-frame-parameters nil '((title . "Guile Studio")))
48
49 ;; Check syntax on the fly
50 (require 'flycheck)
51 (flycheck-define-checker guile
52 "A Guile syntax checker with `guild compile'."
53 :command ("guild" "compile"
54 "--warn=unused-variable"
55 "--warn=unused-toplevel"
56 "--warn=unbound-variable"
57 "--warn=macro-use-before-definition"
58 "--warn=arity-mismatch"
59 "--warn=duplicate-case-datum"
60 "--warn=bad-case-datum"
61 "--warn=format"
62 source)
63 :predicate
64 (lambda ()
65 (and (boundp 'geiser-impl--implementation)
66 (eq geiser-impl--implementation 'guile)))
67 :verify
68 (lambda (checker)
69 (let ((geiser-impl (bound-and-true-p geiser-impl--implementation)))
70 (list
71 (flycheck-verification-result-new
72 :label "Geiser Implementation"
73 :message (cond
74 ((eq geiser-impl 'guile) "Guile")
75 (geiser-impl (format "Other: %s" geiser-impl))
76 (t "Geiser not active"))
77 :face (cond
78 ((or (eq geiser-impl 'guile)) 'success)
79 (t '(bold error)))))))
80 :error-patterns
81 ((warning
82 line-start (file-name) ":" line ":" column ": warning:" (message) line-end)
83 (error
84 line-start (file-name) ":" line ":" column ":" (message) line-end))
85 :modes (scheme-mode geiser-mode))
86 (add-to-list 'flycheck-checkers 'guile)
87 (global-flycheck-mode 1)
88
89 ;; Remember location in buffers
90 (require 'saveplace)
91 (setq-default save-place t)
92
93 ;; Mode line settings
94 (require 'smart-mode-line)
95 (setq sml/no-confirm-load-theme t)
96 (setq sml/theme 'respectful)
97 (setq sml/position-percentage-format nil)
98 (setq sml/mule-info nil)
99 (setq sml/read-only-char
100 (propertize "R" 'display
101 (create-image "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"20\" height=\"14\" viewBox=\"0 0 448 612\">\
102 <path fill=\"currentColor\" \
103 d=\"M400 224h-24v-72C376 68.2 307.8 0 224 0S72 68.2 72 \
104 152v72H48c-26.5 0-48 21.5-48 48v192c0 26.5 21.5 48 48 48h352c26.5 \
105 0 48-21.5 48-48V272c0-26.5-21.5-48-48-48zm-104 0H152v-72c0-39.7 \
106 32.3-72 72-72s72 32.3 72 72v72z\"></path></svg>" 'svg t)))
107 (sml/setup)
108 (setq rm-whitelist '("Paredit"))
109
110 (require 'uniquify)
111 (setq uniquify-buffer-name-style 'forward)
112
113 ;; Add close button for opened buffers.
114 (require 'mouse)
115 (defconst my-mode-line-map
116 (let ((map (make-sparse-keymap)))
117 (define-key map (vector 'mode-line 'mouse-1)
118 'mouse-delete-window)
119 map))
120 (setq global-mode-string
121 (append global-mode-string
122 '(:eval (if (window-dedicated-p (selected-window))
123 ""
124 (propertize "[тип]"
125 'local-map my-mode-line-map
126 'mouse-face 'mode-line-highlight)))))
127 (global-unset-key (vector 'mode-line 'mouse-2)) ; 'mouse-delete-other-windows
128 (global-unset-key (vector 'mode-line 'mouse-3)) ; 'mouse-delete-window
129
130
131 (defun geiser--guile-picture-language--pict-from-file ()
132 (interactive)
133 (let ((file (read-file-name "Insert image: " nil nil t)))
134 (geiser-repl--send
135 (concat "(pict-from-file \""
136 file
137 "\")"))))
138
139 (defvar geiser-repl-tool-bar-map (make-sparse-keymap))
140 (define-key geiser-repl-tool-bar-map (vector 'insert-image)
141 '(menu-item " Insert image" geiser--guile-picture-language--pict-from-file
142 :image
143 (image :type png
144 :file ,(string-append icons "/24x24/actions/insert-image.png"))
145 :help "Insert image..."))
146
147 (defvar scheme-tool-bar-map (make-sparse-keymap))
148 (define-key scheme-tool-bar-map (vector 'eval-buffer)
149 '(menu-item " Evaluate" geiser-eval-buffer
150 :image
151 (image :type png
152 :file ,(string-append icons "/24x24/actions/media-playback-start.png"))
153 :help "Evaluate buffer..."))
154 (define-key scheme-tool-bar-map (vector 'lookup-documentation)
155 '(menu-item " Documentation" geiser-doc-symbol-at-point
156 :image
157 (image :type png
158 :file ,(string-append icons "/24x24/actions/help-faq.png"))
159 :help "Show documentation for the current symbol"))
160
161 (add-hook 'emacs-startup-hook
162 (lambda ()
163 (let ((buf (generate-new-buffer "untitled.scm")))
164 (switch-to-buffer buf nil t)
165 (funcall (and initial-major-mode))
166 (setq buffer-offer-save t)
167 (delete-other-windows)
168 (set-window-dedicated-p (selected-window) t))
169 (run-guile)
170 (set-window-dedicated-p (selected-window) t)
171 ;; Hide the cluttered Tools and Options menu items
172 (define-key global-map (vector 'menu-bar 'tools) 'undefined)
173 (define-key global-map (vector 'menu-bar 'options) 'undefined)
174
175 ;; Prefer horizontal splits
176 (setq split-height-threshold nil)
177 (setq split-width-threshold 80)))
178
179 (add-hook 'after-init-hook 'global-company-mode)
180 (add-hook 'geiser-repl-mode-hook
181 (lambda ()
182 (paren-face-mode 1)
183 (show-paren-mode 1)
184 (unless (local-variable-p 'tool-bar-map)
185 (set (make-local-variable 'tool-bar-map)
186 geiser-repl-tool-bar-map))))
187 (add-hook 'scheme-mode-hook
188 (lambda ()
189 (paren-face-mode 1)
190 (show-paren-mode 1)
191 (unless (local-variable-p 'tool-bar-map)
192 (set (make-local-variable 'tool-bar-map)
193 scheme-tool-bar-map))))
194
195 ;; Don't show the Geiser menu in a Scheme buffer
196 (add-hook 'geiser-mode-hook
197 (lambda ()
198 (define-key geiser-mode-map
199 (vector 'menu-bar 'geiserm) 'undefined)))
200 (load-theme 'adwaita t)))
201
202 (define (make-guile-studio-wrapper prefix share emacsdir)
203 (let ((wrapper (string-append prefix "/bin/guile-studio")))
204 (with-output-to-file wrapper
205 (lambda ()
206 (format #t "#!/bin/sh
207 exec ~a/bin/emacs -Q --load ~a/guile-studio.el
208 "
209 emacsdir share)))
210 (chmod wrapper #o555)))
211
212 (define (main)
213 (match (command-line)
214 ((_ prefix emacsdir picture-language icons . emacs-package-dirs)
215 (let ((share (string-append prefix "/share")))
216 (with-output-to-file (string-append share "/guile-studio.el")
217 (lambda ()
218 (pretty-print (generate-configuration prefix emacsdir picture-language icons emacs-package-dirs)
219 #:display? #f)))
220 (make-guile-studio-wrapper prefix share emacsdir)
221 (with-output-to-file (string-append share "/guile-studio-init")
222 (lambda ()
223 (format #t "~s" '(use-modules (pict))))))
224 #t)
225 ((script . _)
226 (format (current-error-port)
227 "usage: ~a prefix emacsdir picture-language icons emacs-package-dirs ...\n"
228 script))))
229
230 (main)