emacs/guix-build-log.el

   1 ;;; guix-build-log.el --- Major and minor modes for build logs   -*- lexical-binding: t -*-
   2
   3 ;; Copyright © 2015 Alex Kost <alezost@gmail.com>
   4
   5 ;; This file is part of GNU Guix.
   6
   7 ;; GNU Guix is free software; you can redistribute it and/or modify
   8 ;; it under the terms of the GNU General Public License as published by
   9 ;; the Free Software Foundation, either version 3 of the License, or
  10 ;; (at your option) any later version.
  11
  12 ;; GNU Guix is distributed in the hope that it will be useful,
  13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15 ;; GNU General Public License for more details.
  16
  17 ;; You should have received a copy of the GNU General Public License
  18 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  19
  20 ;;; Commentary:
  21
  22 ;; This file provides a major mode (`guix-build-log-mode') and a minor mode
  23 ;; (`guix-build-log-minor-mode') for highlighting Guix build logs.
  24
  25 ;;; Code:
  26
  27 (defgroup guix-build-log nil
  28   "Settings for `guix-build-log-mode'."
  29   :group 'guix)
  30
  31 (defgroup guix-build-log-faces nil
  32   "Faces for `guix-build-log-mode'."
  33   :group 'guix-build-log
  34   :group 'guix-faces)
  35
  36 (defface guix-build-log-title-head
  37   '((t :inherit font-lock-keyword-face))
  38   "Face for '@' symbol of a log title."
  39   :group 'guix-build-log-faces)
  40
  41 (defface guix-build-log-title-start
  42   '((t :inherit guix-build-log-title-head))
  43   "Face for a log title denoting a start of a process."
  44   :group 'guix-build-log-faces)
  45
  46 (defface guix-build-log-title-success
  47   '((t :inherit guix-build-log-title-head))
  48   "Face for a log title denoting a successful end of a process."
  49   :group 'guix-build-log-faces)
  50
  51 (defface guix-build-log-title-fail
  52   '((t :inherit error))
  53   "Face for a log title denoting a failed end of a process."
  54   :group 'guix-build-log-faces)
  55
  56 (defface guix-build-log-title-end
  57   '((t :inherit guix-build-log-title-head))
  58   "Face for a log title denoting an undefined end of a process."
  59   :group 'guix-build-log-faces)
  60
  61 (defface guix-build-log-phase-name
  62   '((t :inherit font-lock-function-name-face))
  63   "Face for a phase name."
  64   :group 'guix-build-log-faces)
  65
  66 (defface guix-build-log-phase-start
  67   '((default :weight bold)
  68     (((class grayscale) (background light)) :foreground "Gray90")
  69     (((class grayscale) (background dark))  :foreground "DimGray")
  70     (((class color) (min-colors 16) (background light))
  71      :foreground "DarkGreen")
  72     (((class color) (min-colors 16) (background dark))
  73      :foreground "LimeGreen")
  74     (((class color) (min-colors 8)) :foreground "green"))
  75   "Face for the start line of a phase."
  76   :group 'guix-build-log-faces)
  77
  78 (defface guix-build-log-phase-end
  79   '((((class grayscale) (background light)) :foreground "Gray90")
  80     (((class grayscale) (background dark))  :foreground "DimGray")
  81     (((class color) (min-colors 16) (background light))
  82      :foreground "ForestGreen")
  83     (((class color) (min-colors 16) (background dark))
  84      :foreground "LightGreen")
  85     (((class color) (min-colors 8)) :foreground "green")
  86     (t :weight bold))
  87   "Face for the end line of a phase."
  88   :group 'guix-build-log-faces)
  89
  90 (defface guix-build-log-phase-success
  91   '((t))
  92   "Face for the 'succeeded' word of a phase line."
  93   :group 'guix-build-log-faces)
  94
  95 (defface guix-build-log-phase-fail
  96   '((t :inherit error))
  97   "Face for the 'failed' word of a phase line."
  98   :group 'guix-build-log-faces)
  99
 100 (defface guix-build-log-phase-seconds
 101   '((t :inherit font-lock-constant-face))
 102   "Face for the number of seconds for a phase."
 103   :group 'guix-build-log-faces)
 104
 105 (defcustom guix-build-log-mode-hook
 106   ;; Not using `compilation-minor-mode' because it rebinds some standard
 107   ;; keys, including M-n/M-p.
 108   '(compilation-shell-minor-mode view-mode)
 109   "Hook run after `guix-build-log-mode' is entered."
 110   :type 'hook
 111   :group 'guix-build-log)
 112
 113 (defvar guix-build-log-phase-name-regexp "`\\([^']+\\)'"
 114   "Regexp for a phase name.")
 115
 116 (defvar guix-build-log-phase-start-regexp
 117   (concat "^starting phase " guix-build-log-phase-name-regexp)
 118   "Regexp for the start line of a 'build' phase.")
 119
 120 (defun guix-build-log-title-regexp (&optional state)
 121   "Return regexp for the log title.
 122 STATE is a symbol denoting a state of the title.  It should be
 123 `start', `fail', `success' or `nil' (for a regexp matching any
 124 state)."
 125   (let* ((word-rx (rx (1+ (any word "-"))))
 126          (state-rx (cond ((eq state 'start)   (concat word-rx "started"))
 127                          ((eq state 'success) (concat word-rx "succeeded"))
 128                          ((eq state 'fail)    (concat word-rx "failed"))
 129                          (t word-rx))))
 130     (rx-to-string
 131      `(and bol (group "@") " " (group (regexp ,state-rx)))
 132      t)))
 133
 134 (defun guix-build-log-phase-end-regexp (&optional state)
 135   "Return regexp for the end line of a 'build' phase.
 136 STATE is a symbol denoting how a build phase was ended.  It should be
 137 `fail', `success' or `nil' (for a regexp matching any state)."
 138   (let ((state-rx (cond ((eq state 'success) "succeeded")
 139                         ((eq state 'fail)    "failed")
 140                         (t (regexp-opt '("succeeded" "failed"))))))
 141     (rx-to-string
 142      `(and bol "phase " (regexp ,guix-build-log-phase-name-regexp)
 143            " " (group (regexp ,state-rx)) " after "
 144            (group (1+ (or digit "."))) " seconds")
 145      t)))
 146
 147 (defvar guix-build-log-phase-end-regexp
 148   ;; For efficiency, it is better to have a regexp for the general line
 149   ;; of the phase end, then to call the function all the time.
 150   (guix-build-log-phase-end-regexp)
 151   "Regexp for the end line of a 'build' phase.")
 152
 153 (defvar guix-build-log-font-lock-keywords
 154   `((,(guix-build-log-title-regexp 'start)
 155      (1 'guix-build-log-title-head)
 156      (2 'guix-build-log-title-start))
 157     (,(guix-build-log-title-regexp 'success)
 158      (1 'guix-build-log-title-head)
 159      (2 'guix-build-log-title-success))
 160     (,(guix-build-log-title-regexp 'fail)
 161      (1 'guix-build-log-title-head)
 162      (2 'guix-build-log-title-fail))
 163     (,(guix-build-log-title-regexp)
 164      (1 'guix-build-log-title-head)
 165      (2 'guix-build-log-title-end))
 166     (,guix-build-log-phase-start-regexp
 167      (0 'guix-build-log-phase-start)
 168      (1 'guix-build-log-phase-name prepend))
 169     (,(guix-build-log-phase-end-regexp 'success)
 170      (0 'guix-build-log-phase-end)
 171      (1 'guix-build-log-phase-name prepend)
 172      (2 'guix-build-log-phase-success prepend)
 173      (3 'guix-build-log-phase-seconds prepend))
 174     (,(guix-build-log-phase-end-regexp 'fail)
 175      (0 'guix-build-log-phase-end)
 176      (1 'guix-build-log-phase-name prepend)
 177      (2 'guix-build-log-phase-fail prepend)
 178      (3 'guix-build-log-phase-seconds prepend)))
 179   "A list of `font-lock-keywords' for `guix-build-log-mode'.")
 180
 181 (defvar guix-build-log-mode-map
 182   (let ((map (make-sparse-keymap)))
 183     (set-keymap-parent map special-mode-map)
 184     (define-key map (kbd "M-n") 'guix-build-log-next-phase)
 185     (define-key map (kbd "M-p") 'guix-build-log-previous-phase)
 186     (define-key map (kbd "TAB") 'guix-build-log-phase-toggle)
 187     (define-key map (kbd "<tab>") 'guix-build-log-phase-toggle)
 188     (define-key map (kbd "<backtab>") 'guix-build-log-phase-toggle-all)
 189     (define-key map [(shift tab)] 'guix-build-log-phase-toggle-all)
 190     map)
 191   "Keymap for `guix-build-log-mode' buffers.")
 192
 193 (defun guix-build-log-phase-start (&optional with-header?)
 194   "Return the start point of the current build phase.
 195 If WITH-HEADER? is non-nil, do not skip 'starting phase ...' header.
 196 Return nil, if there is no phase start before the current point."
 197   (save-excursion
 198     (end-of-line)
 199     (when (re-search-backward guix-build-log-phase-start-regexp nil t)
 200       (unless with-header? (end-of-line))
 201       (point))))
 202
 203 (defun guix-build-log-phase-end ()
 204   "Return the end point of the current build phase."
 205   (save-excursion
 206     (beginning-of-line)
 207     (when (re-search-forward guix-build-log-phase-end-regexp nil t)
 208       (point))))
 209
 210 (defun guix-build-log-phase-hide ()
 211   "Hide the body of the current build phase."
 212   (interactive)
 213   (let ((beg (guix-build-log-phase-start))
 214         (end (guix-build-log-phase-end)))
 215     (when (and beg end)
 216       ;; If not on the header line, move to it.
 217       (when (and (> (point) beg)
 218                  (< (point) end))
 219         (goto-char (guix-build-log-phase-start t)))
 220       (remove-overlays beg end 'invisible t)
 221       (let ((o (make-overlay beg end)))
 222         (overlay-put o 'evaporate t)
 223         (overlay-put o 'invisible t)))))
 224
 225 (defun guix-build-log-phase-show ()
 226   "Show the body of the current build phase."
 227   (interactive)
 228   (let ((beg (guix-build-log-phase-start))
 229         (end (guix-build-log-phase-end)))
 230     (when (and beg end)
 231       (remove-overlays beg end 'invisible t))))
 232
 233 (defun guix-build-log-phase-hidden-p ()
 234   "Return non-nil, if the body of the current build phase is hidden."
 235   (let ((beg (guix-build-log-phase-start)))
 236     (and beg
 237          (cl-some (lambda (o)
 238                     (overlay-get o 'invisible))
 239                   (overlays-at beg)))))
 240
 241 (defun guix-build-log-phase-toggle-function ()
 242   "Return a function to toggle the body of the current build phase."
 243   (if (guix-build-log-phase-hidden-p)
 244       #'guix-build-log-phase-show
 245     #'guix-build-log-phase-hide))
 246
 247 (defun guix-build-log-phase-toggle ()
 248   "Show/hide the body of the current build phase."
 249   (interactive)
 250   (funcall (guix-build-log-phase-toggle-function)))
 251
 252 (defun guix-build-log-phase-toggle-all ()
 253   "Show/hide the bodies of all build phases."
 254   (interactive)
 255   (save-excursion
 256     ;; Some phases may be hidden, and some shown.  Whether to hide or to
 257     ;; show them, it is determined by the state of the first phase here.
 258     (goto-char (point-min))
 259     (let ((fun (save-excursion
 260                  (re-search-forward guix-build-log-phase-start-regexp nil t)
 261                  (guix-build-log-phase-toggle-function))))
 262       (while (re-search-forward guix-build-log-phase-start-regexp nil t)
 263         (funcall fun)))))
 264
 265 (defun guix-build-log-next-phase (&optional arg)
 266   "Move to the next build phase.
 267 With ARG, do it that many times.  Negative ARG means move
 268 backward."
 269   (interactive "^p")
 270   (if arg
 271       (when (zerop arg) (user-error "Try again"))
 272     (setq arg 1))
 273   (let ((search-fun (if (> arg 0)
 274                         #'re-search-forward
 275                       #'re-search-backward))
 276         (n (abs arg))
 277         found last-found)
 278     (save-excursion
 279       (end-of-line (if (> arg 0) 1 0))  ; skip the current line
 280       (while (and (not (zerop n))
 281                   (setq found
 282                         (funcall search-fun
 283                                  guix-build-log-phase-start-regexp
 284                                  nil t)))
 285         (setq n (1- n)
 286               last-found found)))
 287     (when last-found
 288       (goto-char last-found)
 289       (forward-line 0))
 290     (or found
 291         (user-error (if (> arg 0)
 292                         "No next build phase"
 293                       "No previous build phase")))))
 294
 295 (defun guix-build-log-previous-phase (&optional arg)
 296   "Move to the previous build phase.
 297 With ARG, do it that many times.  Negative ARG means move
 298 forward."
 299   (interactive "^p")
 300   (guix-build-log-next-phase (- (or arg 1))))
 301
 302 ;;;###autoload
 303 (define-derived-mode guix-build-log-mode special-mode
 304   "Guix-Build-Log"
 305   "Major mode for viewing Guix build logs.
 306
 307 \\{guix-build-log-mode-map}"
 308   (setq font-lock-defaults '(guix-build-log-font-lock-keywords t)))
 309
 310 ;;;###autoload
 311 (define-minor-mode guix-build-log-minor-mode
 312   "Toggle Guix Build Log minor mode.
 313
 314 With a prefix argument ARG, enable Guix Build Log minor mode if
 315 ARG is positive, and disable it otherwise.  If called from Lisp,
 316 enable the mode if ARG is omitted or nil.
 317
 318 When Guix Build Log minor mode is enabled, it highlights build
 319 log in the current buffer.  This mode can be enabled
 320 programmatically using hooks:
 321
 322   (add-hook 'shell-mode-hook 'guix-build-log-minor-mode)"
 323   :init-value nil
 324   :lighter " Guix-Build-Log"
 325   :group 'guix-build-log
 326   (if guix-build-log-minor-mode
 327       (font-lock-add-keywords nil guix-build-log-font-lock-keywords)
 328     (font-lock-remove-keywords nil guix-build-log-font-lock-keywords))
 329   (when font-lock-mode
 330     (font-lock-fontify-buffer)))
 331
 332 (provide 'guix-build-log)
 333
 334 ;;; guix-build-log.el ends here