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)