Unclutter the Help menu.
[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 confirm-kill-processes nil ; kill Geiser on exit
37 x-select-enable-clipboard t
38 x-select-enable-primary t
39 save-interprogram-paste-before-kill t
40 apropos-do-all t
41 mouse-yank-at-point t
42 require-final-newline t
43 visible-bell t
44 load-prefer-newer t
45 save-place-file (concat user-emacs-directory "places"))
46
47 ;; Hide the fact that this is Emacs
48 (modify-frame-parameters nil '((title . "Guile Studio")))
49
50 ;; Unclutter help menu.
51 (require 'menu-bar)
52 (defun menu-bar-read-guileref ()
53 "Display the Guile Reference manual in Info mode."
54 (interactive)
55 (info "guile"))
56 (setq menu-bar-help-menu
57 (let ((menu (make-sparse-keymap "Help")))
58 (bindings--define-key menu (vector 'about-gnu-project)
59 '(menu-item "About GNU" describe-gnu-project
60 :help "About the GNU System, GNU Project, and GNU/Linux"))
61 (bindings--define-key menu (vector 'about-emacs)
62 '(menu-item "About Emacs" about-emacs
63 :help "Display version number, copyright info, and basic help"))
64 (bindings--define-key menu (vector 'sep2)
65 menu-bar-separator)
66 (bindings--define-key menu (vector 'other-manuals)
67 '(menu-item "All Other Manuals (Info)" Info-directory
68 :help "Read any of the installed manuals"))
69 (bindings--define-key menu (vector 'emacs-manual)
70 '(menu-item "Read the Emacs Manual" info-emacs-manual
71 :help "Full documentation of Emacs features"))
72 (bindings--define-key menu (vector 'guile-reference)
73 '(menu-item "Guile Reference" menu-bar-read-guileref
74 :help "Read the Guile Reference manual"))
75 (bindings--define-key menu (vector 'sep1)
76 menu-bar-separator)
77 (bindings--define-key menu (vector 'emacs-tutorial-language-specific)
78 '(menu-item "Emacs Tutorial (choose language)..."
79 help-with-tutorial-spec-language
80 :help "Learn how to use Emacs (choose a language)"))
81 menu))
82 (bindings--define-key global-map (vector 'menu-bar 'help-menu)
83 (cons (purecopy "Help") menu-bar-help-menu))
84
85 ;; Check syntax on the fly
86 (require 'flycheck)
87 (flycheck-define-checker guile
88 "A Guile syntax checker with `guild compile'."
89 :command ("guild" "compile"
90 "--warn=unused-variable"
91 "--warn=unused-toplevel"
92 "--warn=unbound-variable"
93 "--warn=macro-use-before-definition"
94 "--warn=arity-mismatch"
95 "--warn=duplicate-case-datum"
96 "--warn=bad-case-datum"
97 "--warn=format"
98 source)
99 :predicate
100 (lambda ()
101 (and (boundp 'geiser-impl--implementation)
102 (eq geiser-impl--implementation 'guile)))
103 :verify
104 (lambda (checker)
105 (let ((geiser-impl (bound-and-true-p geiser-impl--implementation)))
106 (list
107 (flycheck-verification-result-new
108 :label "Geiser Implementation"
109 :message (cond
110 ((eq geiser-impl 'guile) "Guile")
111 (geiser-impl (format "Other: %s" geiser-impl))
112 (t "Geiser not active"))
113 :face (cond
114 ((or (eq geiser-impl 'guile)) 'success)
115 (t '(bold error)))))))
116 :error-patterns
117 ((warning
118 line-start (file-name) ":" line ":" column ": warning:" (message) line-end)
119 (error
120 line-start (file-name) ":" line ":" column ":" (message) line-end))
121 :modes (scheme-mode geiser-mode))
122 (add-to-list 'flycheck-checkers 'guile)
123 (global-flycheck-mode 1)
124
125 ;; Remember location in buffers
126 (require 'saveplace)
127 (setq-default save-place t)
128
129 ;; Mode line settings
130 (require 'smart-mode-line)
131 (setq sml/no-confirm-load-theme t)
132 (setq sml/theme 'respectful)
133 (setq sml/position-percentage-format nil)
134 (setq sml/mule-info nil)
135 (setq sml/read-only-char
136 (propertize "R" 'display
137 (create-image "<svg xmlns=\"http://www.w3.org/2000/svg\" width=\"20\" height=\"14\" viewBox=\"0 0 448 612\">\
138 <path fill=\"currentColor\" \
139 d=\"M400 224h-24v-72C376 68.2 307.8 0 224 0S72 68.2 72 \
140 152v72H48c-26.5 0-48 21.5-48 48v192c0 26.5 21.5 48 48 48h352c26.5 \
141 0 48-21.5 48-48V272c0-26.5-21.5-48-48-48zm-104 0H152v-72c0-39.7 \
142 32.3-72 72-72s72 32.3 72 72v72z\"></path></svg>" 'svg t)))
143 (sml/setup)
144 (setq rm-whitelist '("Paredit"))
145
146 (require 'uniquify)
147 (setq uniquify-buffer-name-style 'forward)
148
149 ;; Add close button for opened buffers.
150 (require 'mouse)
151 (defconst my-mode-line-map
152 (let ((map (make-sparse-keymap)))
153 (define-key map (vector 'mode-line 'mouse-1)
154 'mouse-delete-window)
155 map))
156 (setq global-mode-string
157 (append global-mode-string
158 '(:eval (if (window-dedicated-p (selected-window))
159 ""
160 (propertize "[тип]"
161 'local-map my-mode-line-map
162 'mouse-face 'mode-line-highlight)))))
163 (global-unset-key (vector 'mode-line 'mouse-2)) ; 'mouse-delete-other-windows
164 (global-unset-key (vector 'mode-line 'mouse-3)) ; 'mouse-delete-window
165
166
167 (defun geiser--guile-picture-language--pict-from-file ()
168 (interactive)
169 (let ((file (read-file-name "Insert image: " nil nil t)))
170 (geiser-repl--send
171 (concat "(pict-from-file \""
172 file
173 "\")"))))
174
175 (defvar geiser-repl-tool-bar-map (make-sparse-keymap))
176 (define-key geiser-repl-tool-bar-map (vector 'insert-image)
177 '(menu-item " Insert image" geiser--guile-picture-language--pict-from-file
178 :image
179 (image :type png
180 :file ,(string-append icons "/24x24/actions/insert-image.png"))
181 :help "Insert image..."))
182
183 (defvar scheme-tool-bar-map (make-sparse-keymap))
184 (define-key scheme-tool-bar-map (vector 'eval-buffer)
185 '(menu-item " Evaluate" geiser-eval-buffer
186 :image
187 (image :type png
188 :file ,(string-append icons "/24x24/actions/media-playback-start.png"))
189 :help "Evaluate buffer..."))
190 (define-key scheme-tool-bar-map (vector 'lookup-documentation)
191 '(menu-item " Documentation" geiser-doc-symbol-at-point
192 :image
193 (image :type png
194 :file ,(string-append icons "/24x24/actions/help-faq.png"))
195 :help "Show documentation for the current symbol"))
196
197 (add-hook 'emacs-startup-hook
198 (lambda ()
199 (let ((buf (generate-new-buffer "untitled.scm")))
200 (switch-to-buffer buf nil t)
201 (funcall (and initial-major-mode))
202 (setq buffer-offer-save t)
203 (delete-other-windows)
204 (set-window-dedicated-p (selected-window) t))
205 (run-guile)
206 (set-window-dedicated-p (selected-window) t)
207 ;; Hide the cluttered Tools and Options menu items
208 (define-key global-map (vector 'menu-bar 'tools) 'undefined)
209 (define-key global-map (vector 'menu-bar 'options) 'undefined)
210
211 ;; Prefer horizontal splits
212 (setq split-height-threshold nil)
213 (setq split-width-threshold 80)))
214
215 (add-hook 'after-init-hook 'global-company-mode)
216 (add-hook 'geiser-repl-mode-hook
217 (lambda ()
218 (paren-face-mode 1)
219 (show-paren-mode 1)
220 (unless (local-variable-p 'tool-bar-map)
221 (set (make-local-variable 'tool-bar-map)
222 geiser-repl-tool-bar-map))))
223 (add-hook 'scheme-mode-hook
224 (lambda ()
225 (paren-face-mode 1)
226 (show-paren-mode 1)
227 (unless (local-variable-p 'tool-bar-map)
228 (set (make-local-variable 'tool-bar-map)
229 scheme-tool-bar-map))))
230
231 ;; Don't show the Geiser menu in a Scheme buffer
232 (add-hook 'geiser-mode-hook
233 (lambda ()
234 (define-key geiser-mode-map
235 (vector 'menu-bar 'geiserm) 'undefined)))
236 (load-theme 'adwaita t)))
237
238 (define (make-guile-studio-wrapper prefix share emacsdir)
239 (let ((wrapper (string-append prefix "/bin/guile-studio")))
240 (with-output-to-file wrapper
241 (lambda ()
242 (format #t "#!/bin/sh
243 exec ~a/bin/emacs -Q --load ~a/guile-studio.el
244 "
245 emacsdir share)))
246 (chmod wrapper #o555)))
247
248 (define (main)
249 (match (command-line)
250 ((_ prefix emacsdir picture-language icons . emacs-package-dirs)
251 (let ((share (string-append prefix "/share")))
252 (with-output-to-file (string-append share "/guile-studio.el")
253 (lambda ()
254 (pretty-print (generate-configuration prefix emacsdir picture-language icons emacs-package-dirs)
255 #:display? #f)))
256 (make-guile-studio-wrapper prefix share emacsdir)
257 (with-output-to-file (string-append share "/guile-studio-init")
258 (lambda ()
259 (format #t "~s" '(use-modules (pict))))))
260 #t)
261 ((script . _)
262 (format (current-error-port)
263 "usage: ~a prefix emacsdir picture-language icons emacs-package-dirs ...\n"
264 script))))
265
266 (main)