path: root/guile-studio.el

;; (defvar %guile-studio/prefix "@PREFIX@")
;; (defvar %guile-studio/picture-language "@PICTURE_LANGUAGE@")
;; (defvar %guile-studio/emacsdir "@EMACSDIR@")
;; (defvar %guile-studio/guiledir "@GUILEDIR@")
;; (defvar %guile-studio/guile-load-path "@GUILE_LOAD_PATH@")
;; (defvar %guile-studio/guile-load-compiled-path "@GUILE_LOAD_COMPILED_PATH@")

(declare-function guix-emacs-autoload-packages "guix-emacs" ())
(declare-function geiser-repl--send "geiser-repl" (cmd &optional save-history))
(declare-function winner-conf "winner" ())
(declare-function winner-set "winner" (conf))


(let ((guix-emacs.el
       (expand-file-name
        (concat %guile-studio/emacsdir "/share/emacs/site-lisp/guix-emacs.el"))))
  (when (file-exists-p guix-emacs.el)
    (load guix-emacs.el)))
(when (require 'guix-emacs nil t)
  (guix-emacs-autoload-packages))

(setq-default line-spacing 2)
;; Increase default font size
(set-face-attribute 'default nil :height 112)

(setq-default indent-tabs-mode nil)
(tool-bar-mode -1)
(menu-bar-mode 1)
(scroll-bar-mode -1)

(setq window-resize-pixelwise t)

;; Show only buffers with the same major mode in the same tab line.
(require 'tab-line)
(setq tab-line-tabs-function 'tab-line-tabs-mode-buffers)
(setq tab-line-close-tab-function 'kill-buffer)

(require 'ivy)
(ivy-mode 1)
;; Enter directory when hitting RET
(define-key ivy-minibuffer-map (kbd "<return>") 'ivy-alt-done)

(require 'info)
(setq Info-directory-list
      (list (concat %guile-studio/prefix "/share/guile-studio/info/")
            (concat %guile-studio/picture-language "/share/info/")
            (concat %guile-studio/guiledir "/share/info/")))

;; Use Ctrl-C/X/Z for copy, cut, paste
(require 'cua-base)
(cua-mode 1)
(require 'company)
(setq company-idle-delay 0.3)
(require 'elec-pair)
(electric-pair-mode 1)
(require 'scheme)
(require 'geiser)
(require 'paren-face)

;; Add site-ccache directories to %load-compiled-path, and run the
;; init routine.  We don't use geiser-guile-init-file because that
;; would lead to compilation messages in the REPL when Guile
;; Studio is first started.
(defun guile-studio--geiser-guile--parameters (params)
  (append (list "-C" (concat %guile-studio/prefix "/lib/guile/3.0/site-ccache/"))
          (mapcan (lambda (dir) (list "-C" dir))
                  %guile-studio/guile-load-compiled-path)
          params
          (list "-e" "(@ (guile-studio-init) guile-studio-init)")))
(advice-add 'geiser-guile--parameters
            :filter-return (function guile-studio--geiser-guile--parameters))
(setq geiser-guile-load-path
      (mapcan (lambda (dir) (list "-C" dir))
              %guile-studio/guile-load-path))

(setq geiser-autodoc-identifier-format "%s → %s")
(setq geiser-default-implementation 'guile
      geiser-active-implementations '(guile)
      geiser-mode-smart-tab-p t

      initial-major-mode 'scheme-mode
      inhibit-splash-screen t
      confirm-kill-processes nil      ; kill Geiser on exit
      select-enable-clipboard t
      select-enable-primary t
      save-interprogram-paste-before-kill t
      mouse-yank-at-point t
      require-final-newline t
      visible-bell nil
      load-prefer-newer t)

(setq ring-bell-function
      (lambda ()
        (let ((orig-fg (face-foreground 'mode-line)))
          (set-face-foreground 'mode-line "#F2804F")
          (run-with-idle-timer 0.1 nil
                               (lambda (fg) (set-face-foreground 'mode-line fg))
                               orig-fg))))

;; Hide the fact that this is Emacs
(modify-frame-parameters nil '((title . "Guile Studio")))

(defun menu-bar-read-guileref ()
  "Display the Guile Reference manual in Info mode."
  (interactive)
  (info "guile"))
(defun menu-bar-read-pictref ()
  "Display the Picture Language manual in Info mode."
  (interactive)
  (info "picture-language"))

(defun string-display-pixel-width (string)
  "Calculate pixel width of STRING."
  (with-temp-buffer
    (with-silent-modifications
      (setf (buffer-string) string))
    (variable-pitch-mode 1)
    (if (get-buffer-window (current-buffer))
        (car (window-text-pixel-size nil (line-beginning-position) (point)))
      (set-window-buffer nil (current-buffer))
      (car (window-text-pixel-size nil (line-beginning-position) (point))))))

(defun right-align (string &optional center-p)
  (let ((right-margin 3))
    (concat
     (propertize " " 'display
			     `(space :align-to
                         (- ,(if center-p 'center 'right)
                            (,(+ right-margin (string-display-pixel-width string))))))
     string)))

;; Adapted from fancy-splash-insert
(defun guile-studio-splash-insert (&rest args)
  (let ((current-face nil))
    (while args
      (cond ((eq (car args) :face)
	         (setq args (cdr args) current-face (car args))
	         (if (functionp current-face)
		         (setq current-face (funcall current-face))))
	        ((eq (car args) :link)
	         (setq args (cdr args))
	         (let ((spec (car args)))
	           (if (functionp spec)
		           (setq spec (funcall spec)))
	           (insert-button (car spec)
			                  'face (list 'link current-face)
			                  'action (cadr spec)
			                  'help-echo (concat "mouse-2, RET: "
						                         (or (nth 2 spec)
						                             "Follow this link"))
			                  'follow-link t)))
	        (t
             (insert (propertize (car args) 'face current-face))))
      (setq args (cdr args)))))

(defvar about-guile-studio-text
  `((:face variable-pitch
           "Welcome to Guile Studio, an Emacs environment to play
with the "
           :link ("GNU Guile programming language"
	              ,(lambda (_button) (browse-url "https://www.gnu.org/software/guile/"))
	              "Browse https://www.gnu.org/software/guile/")
           " and its picture language.\n\n"

           :face modus-theme-heading-1 "Manuals\n"
           :face variable-pitch
           "  Learn all about Guile "
           :link (,(right-align "View Guile Manual")
                  ,(lambda (_button) (menu-bar-read-guileref)))
           "\n"
           "  How to draw pictures "
           :link (,(right-align "View Picture Language Manual")
                  ,(lambda (_button) (menu-bar-read-pictref)))
           "\n\n"
           :face modus-theme-heading-1 "Common commands\n"
           :face variable-pitch
           "  Save " ,(right-align "C-x C-s" t) "\t"
           "  Help " ,(right-align "C-h") "\n"
           
           "  Save as " ,(right-align "C-x C-w" t) "\t"
           "  Cancel " ,(right-align "C-g") "\n"

           "  Open a new file " ,(right-align "C-x C-f" t) "\t"
           "  Undo " ,(right-align "C-/") "\n"

           "  Close side window " ,(right-align "q" t) "\t"
           "  Close buffer " ,(right-align "C-x k") "\n"

           "  Browse directory " ,(right-align "C-x d" t) "\t"
           "  Quit " ,(right-align "C-x C-c") "\n"
           "\n"
           "Access a context-specific menu by right-clicking.\n"
           "Toggle between dark and light mode with F5."
           "\n")))

(defun about-guile-studio ()
  "Display the Guile Studio about buffer."
  (interactive)
  (let ((splash-buffer (get-buffer-create "*Guile Studio*")))
    (with-current-buffer
        splash-buffer
      (let ((inhibit-read-only t))
        (erase-buffer)
        (setq default-directory command-line-default-directory)
        (make-local-variable 'startup-screen-inhibit-startup-screen)
        (let* ((image-file (concat %guile-studio/prefix "/share/logo.svg"))
	           (img (create-image image-file))
	           (image-width (and img (car (image-size img))))
	           (window-width (window-width)))
          (when img
            (insert "\n")
            (when (> window-width image-width)
              ;; Center the image in the window.
	          (insert (propertize " " 'display
			                      `(space :align-to (+ center (-0.5 . ,img)))))

              ;; Insert the image with a help-echo and a link.
	          (make-button (prog1 (point) (insert-image img)) (point)
		                   'face 'default
		                   'help-echo "mouse-2, RET: Browse https://www.gnu.org/software/guile"
		                   'action (lambda (_button) (browse-url "https://www.gnu.org/software/guile"))
		                   'follow-link t)
	          (insert "\n\n"))))
        (dolist (text about-guile-studio-text)
          (apply (function guile-studio-splash-insert) text)
          (insert "\n")))
      (use-local-map splash-screen-keymap)
      (setq buffer-read-only t)
      (set-buffer-modified-p nil)
      (if (and view-read-only (not view-mode))
          (view-mode-enter nil 'kill-buffer))
      (goto-char (point-min))
      (forward-line 4))
    (pop-to-buffer splash-buffer 'display-buffer-in-side-window)))

;; Unclutter help menu.
(require 'menu-bar)
(setq menu-bar-help-menu
      (let ((menu (make-sparse-keymap "Help")))
        (bindings--define-key menu (vector 'about-gnu-project)
          '(menu-item "About GNU" describe-gnu-project
                      :help "About the GNU System, GNU Project, and GNU/Linux"))
        (bindings--define-key menu (vector 'about-guile-studio)
          '(menu-item "About Guile Studio" about-guile-studio
                      :help "About this program"))
        (bindings--define-key menu (vector 'sep2)
          menu-bar-separator)
        (bindings--define-key menu (vector 'other-manuals)
          '(menu-item "All Other Manuals (Info)" Info-directory
                      :help "Read any of the installed manuals"))
        (bindings--define-key menu (vector 'guile-reference)
          '(menu-item "Guile Reference" menu-bar-read-guileref
                      :help "Read the Guile Reference manual"))
        menu))
(bindings--define-key global-map (vector 'menu-bar 'help-menu)
  (cons (purecopy "Help") menu-bar-help-menu))

;; Unclutter File menu
(setq menu-bar-file-menu
      (let ((menu (make-sparse-keymap "File")))
        (bindings--define-key menu (vector 'exit-emacs)
          '(menu-item "Quit" save-buffers-kill-terminal
                      :help "Save unsaved buffers, then exit"))
        (bindings--define-key menu (vector 'sep-exit)
          menu-bar-separator)
        (bindings--define-key menu (vector 'revert-buffer)
          '(menu-item "Revert Buffer" revert-buffer
                      :enable
                      (or
                       (not
                        (eq revert-buffer-function 'revert-buffer--default))
                       (not
                        (eq revert-buffer-insert-file-contents-function
                            'revert-buffer-insert-file-contents--default-function))
                       (and buffer-file-number
                            (not
                             (verify-visited-file-modtime
                              (current-buffer)))))
                      :help "Re-read current buffer from its file"))
        (bindings--define-key menu (vector 'write-file)
          '(menu-item "Save As..." write-file
                      :enable menu-bar-menu-frame-live-and-visible-p
                      :help "Write current buffer to another file"))
        (bindings--define-key menu (vector 'save-buffer)
          '(menu-item "Save" save-buffer :enable
                      (and (buffer-modified-p)
                           (buffer-file-name))
                      :help "Save current buffer to its file"))
        (bindings--define-key menu (vector 'sep-save)
          menu-bar-separator)
        (bindings--define-key menu (vector 'kill-buffer)
          '(menu-item "Close" kill-this-buffer :enable
                      (kill-this-buffer-enabled-p)
                      :help "Discard (kill) current buffer"))

        (bindings--define-key menu (vector 'dired)
          '(menu-item "Open File..." dired-sidebar-show-sidebar
                      :help "Show the directory browser in a side bar"))
        (bindings--define-key menu (vector 'new-file)
          '(menu-item "New File" (lambda ()
                                   (interactive)
                                   (select-window
                                    (get-window-with-predicate
                                     (lambda (window)
                                       (window-parameter window 'guile-studio/edit))))
                                   (find-file "untitled.scm"))
                      :help "Create a new file buffer"))
        menu))
(bindings--define-key global-map (vector 'menu-bar 'file)
  (cons (purecopy "File") menu-bar-file-menu))

;; Unclutter Edit menu
(define-key menu-bar-edit-menu (vector 'goto) nil)
(define-key menu-bar-edit-menu (vector 'bookmark) nil)
(define-key menu-bar-edit-menu (vector 'separator-bookmark) nil)
(define-key menu-bar-edit-menu (vector 'fill) nil)
(define-key menu-bar-edit-menu (vector 'props) nil)

(define-key menu-bar-edit-menu (vector 'replace 'tags-repl) nil)
(define-key menu-bar-edit-menu (vector 'replace 'tags-repl-continue) nil)
(define-key menu-bar-edit-menu (vector 'search)
  '(menu-item "Search..." isearch-forward-regexp
              :help "Incrementally search for a regular expression"))

;; Check syntax on the fly
(require 'flycheck)
(require 'flycheck-guile)
(global-flycheck-mode 1)

;; Remember location in buffers
(require 'saveplace)
(setq-default save-place t)

;; Right side window
(defvar popup-right-side-windows
  (rx (or "*Guile Studio*"
          "*Geiser documentation*"
          (seq "*Help" (* anychar) "*")
          "*info*")))
(add-to-list 'display-buffer-alist
             `(,popup-right-side-windows
               (display-buffer-reuse-window
                display-buffer-in-side-window)
               (inhibit-same-window . t)
               (side            . right)
               (slot            . 0)
               (preserve-size   . (t . t))
               (window-width    . 80)
               (window-height   . 1.0)))

;; Bottom side window
(defvar popup-bottom-windows
  (rx (or "*Flycheck*"
          "*Flymake*"
          "*Backtrace*"
          "*Warnings*"
          "*Compile-Log*"
          "*Messages*"
          (seq (* anychar) "*Completions" (* anychar)))))
(add-to-list 'display-buffer-alist
             `(,popup-bottom-windows
               (display-buffer-reuse-window
                display-buffer-in-side-window)
               (inhibit-same-window . t)
               (side            . bottom)
               (slot            . 0)
               (preserve-size   . (t . t))
               (window-height   . 0.16)))

(defvar bottom-windows
  (rx (or (seq "* Guile REPL *" (* anychar))
          "*Geiser dbg*")))
(add-to-list 'display-buffer-alist
             `(,bottom-windows
               (display-buffer-reuse-window
                display-buffer-at-bottom)
               (window-height   . 10)))

(require 'dired-sidebar)
(global-set-key (kbd "C-x d") 'dired-sidebar-toggle-sidebar)
;; Delete dired window on "q"
(define-key dired-mode-map (kbd "q") 'delete-window)
(setq dired-sidebar-one-instance-p t
      dired-sidebar-close-sidebar-on-file-open t)

;; Mode line settings
(require 'doom-modeline)
(setq doom-modeline-buffer-encoding nil)

;; Remove incorrect help echo from buffer name
(require 'doom-modeline-segments)
(doom-modeline-def-segment buffer-info
  (concat
   (doom-modeline-spc)
   (doom-modeline--buffer-mode-icon)
   (doom-modeline--buffer-state-icon)
   (propertize "%b" 'face 'doom-modeline-buffer-file)))
(doom-modeline-mode 1)

;; Stop using the minibuffer when leaving it
(defun stop-using-minibuffer ()
  "kill the minibuffer"
  (when (and (>= (recursion-depth) 1) (active-minibuffer-window))
    (abort-recursive-edit)))
(add-hook 'mouse-leave-buffer-hook 'stop-using-minibuffer)

(require 'uniquify)
(setq uniquify-buffer-name-style 'forward)

;; Add close button for opened buffers.
(require 'mouse)
(defconst my-mode-line-map
  (let ((map (make-sparse-keymap)))
    (define-key map (vector 'mode-line 'mouse-1)
      'mouse-delete-window)
    map))
(setq global-mode-string 
      (append global-mode-string 
              '(:eval (if (window-dedicated-p (selected-window))
                          ""
                        (propertize "[⨯]"
                                    'local-map my-mode-line-map
                                    'mouse-face 'mode-line-highlight)))))
(global-unset-key (vector 'mode-line 'mouse-2)) ; 'mouse-delete-other-windows
(global-unset-key (vector 'mode-line 'mouse-3)) ; 'mouse-delete-window

;; Don't switch buffers when clicking on the name.
(define-key mode-line-buffer-identification-keymap (vector 'mode-line 'mouse-1) nil)
(define-key mode-line-buffer-identification-keymap (vector 'mode-line 'mouse-3) nil)

;; Context menu on right click.
(defun context-menu ()
  (let ((menu (make-sparse-keymap)))
    (pcase major-mode
      ('geiser-repl-mode
       (define-key menu (vector 'insert-image)
         '("Insert image" . geiser--guile-picture-language--pict-from-file))
       menu)
      ('scheme-mode
       (define-key menu (vector 'switch-to-repl)
         '("Switch to REPL" . switch-to-geiser))
       (define-key menu (vector 'eval-buffer)
         '("Evaluate buffer" . geiser-eval-buffer))
       (define-key menu (vector 'lookup-documentation)
         '("Show documentation". geiser-doc-symbol-at-point))
       menu)
      (_
       (mouse-menu-major-mode-map)))))

(global-set-key (vector 'mouse-3)
                (lambda (event)
                  (interactive "e")
                  (mouse-set-point event)
                  (popup-menu (context-menu))))

(defun geiser--guile-picture-language--pict-from-file ()
  (interactive)
  (let ((file (read-file-name "Insert image: " nil nil t nil
                              (lambda (name)
                                (or (string-suffix-p ".svg" name t)
                                    (string-suffix-p ".png" name t))))))
    (geiser-repl--send
     (concat "(pict-from-file \""
             file
             "\")"))))

(add-to-list 'initial-frame-alist
             '(fullscreen . maximized))

(add-hook 'emacs-startup-hook
          (lambda ()
            (require 'winner)
            (winner-mode 1)
            (let ((buf (generate-new-buffer "untitled.scm")))
              (with-current-buffer buf
                (switch-to-buffer buf nil t)
                (set-window-dedicated-p (selected-window) nil)
                (set-window-parameter (selected-window) 'guile-studio/edit t)
                (funcall (and initial-major-mode))
                (insert ";;; Welcome to Guile Studio!\n")
                (insert ";;; Type your Guile program here and evaluate it.\n\n")
                (setq buffer-offer-save t)

                (switch-to-geiser)
                (set-window-dedicated-p (selected-window) t)
                (call-interactively 'about-guile-studio))

              ;; This is necessary to show the REPL prompt after
              ;; displaying the side window.
              (pop-to-buffer "* Guile REPL *"))

            ;; Always restore default layout
            (defvar guile-studio--layout (winner-conf))
            (define-key global-map (kbd "ESC ESC ESC")
              (lambda ()
                (interactive)
                (keyboard-escape-quit)
                (winner-set guile-studio--layout)))
            (kill-buffer "*scratch*")

            ;; Hide the cluttered Tools and Options menu items
            (define-key global-map (vector 'menu-bar 'tools) 'undefined)
            (define-key global-map (vector 'menu-bar 'options) 'undefined)))

(add-hook 'after-init-hook 'global-company-mode)
(add-hook 'geiser-repl-mode-hook
          (lambda ()
            (paren-face-mode 1)
            (show-paren-mode 1)))
(add-hook 'scheme-mode-hook
          (lambda ()
            (paren-face-mode 1)
            (show-paren-mode 1)
            (tab-line-mode 1)
            (display-line-numbers-mode 1)))

;; Don't show the Geiser menu in a Scheme buffer
(add-hook 'geiser-mode-hook
          (lambda ()
            (define-key geiser-mode-map
              (vector 'menu-bar 'geiserm) 'undefined)))

;; Color theme
(require 'modus-themes)               ; common code
(require 'modus-operandi-theme)       ; light theme
(require 'modus-vivendi-theme)        ; dark theme
(setq modus-themes-scale-headings t
      modus-themes-variable-pitch-headings t
      modus-themes-bold-constructs t
      modus-themes-links 'no-underline)
(defun tweak-theme ()
  "Increase tab margins."
  (let ((palette (modus-themes--active-theme)))
    (set-face-attribute 'tab-line-tab nil
                        :box `(:line-width 8
                                           :color ,(cdr (assoc 'bg-tab-active palette))))
    (set-face-attribute 'tab-line-tab-inactive nil
                        :box `(:line-width 8
                                           :color ,(cdr (assoc 'bg-tab-inactive palette))))
    ;; Remove border around mode line
    (set-face-attribute 'mode-line nil
                        :box nil)
    (set-face-attribute 'mode-line-inactive nil
                        :box nil)))
(add-hook 'modus-themes-after-load-theme-hook 'tweak-theme)
(global-set-key (kbd "<f5>") 'modus-themes-toggle)
(load-theme 'modus-operandi t)
(tweak-theme)