cgit.sxemacs.org Git - gnus/blob - lisp/assistant.el

   1 ;;; assistant.el --- guiding users through Emacs setup
   2 ;; Copyright (C) 2004 Free Software Foundation, Inc.
   3
   4 ;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
   5 ;; Keywords: util
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  21 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  22 ;; Boston, MA 02111-1307, USA.
  23
  24 ;;; Commentary:
  25
  26 ;;; Code:
  27
  28 (eval-when-compile
  29   (require 'cl))
  30
  31 (require 'widget)
  32 (require 'wid-edit)
  33
  34 (defvar assistant-readers
  35   '(("variable" assistant-variable-reader)
  36     ("validate" assistant-sexp-reader)
  37     ("result" assistant-list-reader)
  38     ("next" assistant-list-reader)
  39     ("text" assistant-text-reader)))
  40
  41 (defface assistant-field-face '((t (:bold t)))
  42   "Face used for editable fields."
  43   :group 'gnus-article-emphasis)
  44
  45 ;;; Internal variables
  46
  47 (defvar assistant-data nil)
  48 (defvar assistant-current-node nil)
  49 (defvar assistant-previous-nodes nil)
  50 (defvar assistant-widgets nil)
  51
  52 (defun assistant-parse-buffer ()
  53   (let (results command value)
  54     (goto-char (point-min))
  55     (while (search-forward "@" nil t)
  56       (if (not (looking-at "[^ \t\n]+"))
  57           (error "Dangling @")
  58         (setq command (downcase (match-string 0)))
  59         (goto-char (match-end 0)))
  60       (setq value
  61             (if (looking-at "[ \t]*\n")
  62                 (let (start)
  63                   (forward-line 1)
  64                   (setq start (point))
  65                   (unless (re-search-forward (concat "^@end " command) nil t)
  66                     (error "No @end %s found" command))
  67                   (beginning-of-line)
  68                   (prog1
  69                       (buffer-substring start (point))
  70                     (forward-line 1)))
  71               (skip-chars-forward " \t")
  72               (prog1
  73                   (buffer-substring (point) (line-end-position))
  74                 (forward-line 1))))
  75       (push (list command (assistant-reader command value))
  76             results))
  77     (assistant-segment (nreverse results))))
  78
  79 (defun assistant-text-reader (text)
  80   (with-temp-buffer
  81     (insert text)
  82     (goto-char (point-min))
  83     (let ((start (point))
  84           (sections nil))
  85       (while (re-search-forward "@\\([^{]+\\){\\([^}]+\\)}" nil t)
  86         (push (buffer-substring start (match-beginning 0))
  87               sections)
  88         (push (list (match-string 1) (match-string 2))
  89               sections)
  90         (setq start (point)))
  91       (push (buffer-substring start (point-max))
  92             sections)
  93       (nreverse sections))))
  94
  95 ;; Segment the raw assistant data into a list of nodes.
  96 (defun assistant-segment (list)
  97   (let ((ast nil)
  98         (node nil)
  99         (title (pop list)))
 100     (dolist (elem list)
 101       (when (and (equal (car elem) "node")
 102                  node)
 103         (push (list "save" nil) node)
 104         (push (nreverse node) ast)
 105         (setq node nil))
 106       (push elem node))
 107     (when node
 108       (push (list "save" nil) node)
 109       (push (nreverse node) ast))
 110     (cons title (nreverse ast))))
 111
 112 (defun assistant-reader (command value)
 113   (let ((formatter (cadr (assoc command assistant-readers))))
 114     (if (not formatter)
 115         value
 116       (funcall formatter value))))
 117
 118 (defun assistant-list-reader (value)
 119   (car (read-from-string (concat "(" value ")"))))
 120
 121 (defun assistant-variable-reader (value)
 122   (let ((section (car (read-from-string (concat "(" value ")")))))
 123     (append section (list 'default))))
 124
 125 (defun assistant-sexp-reader (value)
 126   (if (zerop (length value))
 127       nil
 128     (car (read-from-string value))))
 129
 130 (defun assistant-buffer-name (title)
 131   (format "*Assistant %s*" title))
 132
 133 (defun assistant-get (ast command)
 134   (cadr (assoc command ast)))
 135
 136 (defun assistant-set (ast command value)
 137   (let ((elem (assoc command ast)))
 138     (when elem
 139       (setcar (cdr elem) value))))
 140
 141 (defun assistant-get-list (ast command)
 142   (let ((result nil))
 143     (dolist (elem ast)
 144       (when (equal (car elem) command)
 145         (push elem result)))
 146     (nreverse result)))
 147
 148 ;;;###autoload
 149 (defun assistant (file)
 150   "Assist setting up Emacs based on FILE."
 151   (interactive "fAssistant file name: ")
 152   (let ((ast
 153          (with-temp-buffer
 154            (insert-file-contents file)
 155            (assistant-parse-buffer))))
 156     (pop-to-buffer (assistant-buffer-name (assistant-get ast "title")))
 157     (assistant-render ast)))
 158
 159 (defun assistant-render (ast)
 160   (let ((first-node (assistant-get (nth 1 ast) "node")))
 161     (set (make-local-variable 'assistant-data) ast)
 162     (set (make-local-variable 'assistant-current-node) nil)
 163     (set (make-local-variable 'assistant-previous-nodes) nil)
 164     (assistant-render-node first-node)))
 165
 166 (defun assistant-find-node (node-name)
 167   (let ((ast (cdr assistant-data)))
 168     (while (and ast
 169                 (not (string= node-name (assistant-get (car ast) "node"))))
 170       (pop ast))
 171     (car ast)))
 172
 173 (defun assistant-node-name (node)
 174   (assistant-get node "node"))
 175
 176 (defun assistant-previous-node-text (node)
 177   (format "<< Go back to %s" node))
 178
 179 (defun assistant-next-node-text (node)
 180   (if (and node
 181            (not (eq node 'finish)))
 182       (format "Proceed to %s >>" node)
 183     "Finish"))
 184
 185 (defun assistant-set-defaults (node &optional forcep)
 186   (dolist (variable (assistant-get-list node "variable"))
 187     (setq variable (cadr variable))
 188     (when (or (eq (nth 3 variable) 'default)
 189               forcep)
 190       (setcar (nthcdr 3 variable)
 191               (assistant-eval (nth 2 variable))))))
 192
 193 (defun assistant-get-variable (node variable &optional type raw)
 194   (let ((variables (assistant-get-list node "variable"))
 195         (result nil)
 196         elem)
 197     (while (and (setq elem (pop variables))
 198                 (not result))
 199       (setq elem (cadr elem))
 200       (when (eq (intern variable) (car elem))
 201         (if type
 202             (setq result (nth 1 elem))
 203           (setq result (if raw (nth 3 elem)
 204                          (format "%s" (nth 3 elem)))))))
 205     result))
 206
 207 (defun assistant-set-variable (node variable value)
 208   (let ((variables (assistant-get-list node "variable"))
 209         elem)
 210     (while (setq elem (pop variables))
 211       (setq elem (cadr elem))
 212       (when (eq (intern variable) (car elem))
 213         (setcar (nthcdr 3 elem) value)))))
 214
 215 (defun assistant-render-text (text node)
 216   (unless (and text node)
 217     (gnus-error
 218      5
 219      "The assistant was asked to render invalid text or node data"))
 220   (dolist (elem text)
 221     (if (stringp elem)
 222         ;; Ordinary text
 223         (insert elem)
 224       ;; A variable to be inserted as a widget.
 225       (let* ((start (point))
 226              (variable (cadr elem))
 227              (type (assistant-get-variable node variable 'type)))
 228         (cond
 229          ((eq (car-safe type) :radio)
 230           (push
 231            (apply
 232             #'widget-create
 233             'radio-button-choice
 234             :assistant-variable variable
 235             :assistant-node node
 236             :value (assistant-get-variable node variable)
 237             :notify (lambda (widget &rest ignore)
 238                       (assistant-set-variable
 239                        (widget-get widget :assistant-node)
 240                        (widget-get widget :assistant-variable)
 241                        (widget-value widget))
 242                       (assistant-render-node
 243                        (assistant-get
 244                         (widget-get widget :assistant-node)
 245                         "node")))
 246             (cadr type))
 247            assistant-widgets))
 248          ((eq (car-safe type) :set)
 249           (push
 250            (apply
 251             #'widget-create
 252             'set
 253             :assistant-variable variable
 254             :assistant-node node
 255             :value (assistant-get-variable node variable nil t)
 256             :notify (lambda (widget &rest ignore)
 257                       (assistant-set-variable
 258                        (widget-get widget :assistant-node)
 259                        (widget-get widget :assistant-variable)
 260                        (widget-value widget))
 261                       (assistant-render-node
 262                        (assistant-get
 263                         (widget-get widget :assistant-node)
 264                         "node")))
 265             (cadr type))
 266            assistant-widgets))
 267          (t
 268           (push
 269            (widget-create
 270             'editable-field
 271             :value-face 'assistant-field-face
 272             :assistant-variable variable
 273             (assistant-get-variable node variable))
 274            assistant-widgets)
 275           ;; The editable-field widget apparently inserts a newline;
 276           ;; remove it.
 277           (delete-char -1)
 278           (add-text-properties start (point)
 279                                (list
 280                                 'bold t
 281                                 'face 'assistant-field-face
 282                                 'not-read-only t))))))))
 283
 284 (defun assistant-render-node (node-name)
 285   (let ((node (assistant-find-node node-name))
 286         (inhibit-read-only t)
 287         (previous assistant-current-node)
 288         (buffer-read-only nil))
 289     (unless node
 290       (gnus-error 5 "The node for %s could not be found" node-name))
 291     (set (make-local-variable 'assistant-widgets) nil)
 292     (assistant-set-defaults node)
 293     (if (equal (assistant-get node "type") "interstitial")
 294         (assistant-render-node (nth 0 (assistant-find-next-nodes node-name)))
 295       (setq assistant-current-node node-name)
 296       (when previous
 297         (push previous assistant-previous-nodes))
 298       (erase-buffer)
 299       (insert (cadar assistant-data) "\n\n")
 300       (insert node-name "\n\n")
 301       (assistant-render-text (assistant-get node "text") node)
 302       (insert "\n\n")
 303       (when assistant-previous-nodes
 304         (assistant-node-button 'previous (car assistant-previous-nodes)))
 305       (widget-create
 306        'push-button
 307        :assistant-node node-name
 308        :notify (lambda (widget &rest ignore)
 309                  (let* ((node (widget-get widget :assistant-node)))
 310                    (assistant-set-defaults (assistant-find-node node) 'force)
 311                    (assistant-render-node node)))
 312        "Reset")
 313       (insert "\n")
 314       (dolist (nnode (assistant-find-next-nodes))
 315         (assistant-node-button 'next nnode)
 316         (insert "\n"))
 317
 318       (goto-char (point-min))
 319       (assistant-make-read-only))))
 320
 321 (defun assistant-make-read-only ()
 322   (let ((start (point-min))
 323         end)
 324     (while (setq end (text-property-any start (point-max) 'not-read-only t))
 325       (put-text-property start end 'read-only t)
 326       (put-text-property start end 'rear-nonsticky t)
 327       (while (get-text-property end 'not-read-only)
 328         (incf end))
 329       (setq start end))
 330     (put-text-property start (point-max) 'read-only t)))
 331
 332 (defun assistant-node-button (type node)
 333   (let ((text (if (eq type 'next)
 334                   (assistant-next-node-text node)
 335                 (assistant-previous-node-text node))))
 336     (widget-create
 337      'push-button
 338      :assistant-node node
 339      :assistant-type type
 340      :notify (lambda (widget &rest ignore)
 341                (let* ((node (widget-get widget :assistant-node))
 342                       (type (widget-get widget :assistant-type)))
 343                  (if (eq type 'previous)
 344                      (progn
 345                        (setq assistant-current-node nil)
 346                        (pop assistant-previous-nodes))
 347                    (assistant-get-widget-values)
 348                    (assistant-validate))
 349                  (if (null node)
 350                      (assistant-finish)
 351                    (assistant-render-node node))))
 352      text)
 353     (use-local-map widget-keymap)))
 354
 355 (defun assistant-validate-types (node)
 356   (dolist (variable (assistant-get-list node "variable"))
 357     (setq variable (cadr variable))
 358     (let ((type (nth 1 variable))
 359           (value (nth 3 variable)))
 360       (when
 361           (cond
 362            ((eq type :number)
 363             (string-match "[^0-9]" value))
 364            (t
 365             nil))
 366         (error "%s is not of type %s: %s"
 367                (car variable) type value)))))
 368
 369 (defun assistant-get-widget-values ()
 370   (let ((node (assistant-find-node assistant-current-node)))
 371     (dolist (widget assistant-widgets)
 372       (assistant-set-variable
 373        node (widget-get widget :assistant-variable)
 374        (widget-value widget)))))
 375
 376 (defun assistant-validate ()
 377   (let* ((node (assistant-find-node assistant-current-node))
 378          (validation (assistant-get node "validate"))
 379          result)
 380     (assistant-validate-types node)
 381     (when validation
 382       (when (setq result (assistant-eval validation))
 383         (unless (y-or-n-p (format "Error: %s.  Continue? " result))
 384           (error "%s" result))))
 385     (assistant-set node "save" t)))
 386
 387 ;; (defun assistant-find-next-node (&optional node)
 388 ;;   (let* ((node (assistant-find-node (or node assistant-current-node)))
 389 ;;       (node-name (assistant-node-name node))
 390 ;;       (nexts (assistant-get-list node "next"))
 391 ;;       next elem applicable)
 392
 393 ;;     (while (setq elem (pop nexts))
 394 ;;       (when (assistant-eval (car (cadr elem)))
 395 ;;      (setq applicable (cons elem applicable))))
 396
 397 ;;     ;; return the first thing we can
 398 ;;     (cadr (cadr (pop applicable)))))
 399
 400 (defun assistant-find-next-nodes (&optional node)
 401   (let* ((node (assistant-find-node (or node assistant-current-node)))
 402          (nexts (assistant-get-list node "next"))
 403          next elem applicable return)
 404
 405     (while (setq elem (pop nexts))
 406       (when (assistant-eval (car (cadr elem)))
 407         (setq applicable (cons elem applicable))))
 408
 409     ;; return the first thing we can
 410
 411     (while (setq elem (pop applicable))
 412       (push (cadr (cadr elem)) return))
 413
 414     return))
 415
 416 (defun assistant-get-all-variables ()
 417   (let ((variables nil))
 418     (dolist (node (cdr assistant-data))
 419       (setq variables
 420             (append (assistant-get-list node "variable")
 421                     variables)))
 422     variables))
 423
 424 (defun assistant-eval (form)
 425   (let ((bindings nil))
 426     (dolist (variable (assistant-get-all-variables))
 427       (setq variable (cadr variable))
 428       (push (list (car variable)
 429                   (if (eq (nth 3 variable) 'default)
 430                       nil
 431                     (if (listp (nth 3 variable))
 432                         `(list ,@(nth 3 variable))
 433                       (nth 3 variable))))
 434             bindings))
 435     (eval
 436      `(let ,bindings
 437         ,form))))
 438
 439 (defun assistant-finish ()
 440   (let ((results nil)
 441         result)
 442     (dolist (node (cdr assistant-data))
 443       (when (assistant-get node "save")
 444         (setq result (assistant-get node "result"))
 445         (push (list (car result)
 446                     (assistant-eval (cadr result)))
 447               results)))
 448     (message "Results: %s"
 449              (nreverse results))))
 450
 451 ;;; Validation functions.
 452
 453 (defun assistant-validate-connect-to-server (server port)
 454   (let* ((error nil)
 455          (stream
 456           (condition-case err
 457               (open-network-stream "nntpd" nil server port)
 458             (error (setq error err)))))
 459     (if (and (processp stream)
 460              (memq (process-status stream) '(open run)))
 461         (progn
 462           (delete-process stream)
 463           nil)
 464       error)))
 465
 466 (defun assistant-authinfo-data (server port type)
 467   (when (file-exists-p "~/.authinfo")
 468     (netrc-get (netrc-machine (netrc-parse "~/.authinfo")
 469                               server port)
 470                (if (eq type 'user)
 471                    "login"
 472                  "password"))))
 473
 474 (defun assistant-password-required-p ()
 475   nil)
 476
 477 (provide 'assistant)
 478
 479 ;;; arch-tag: 0404bfa2-9226-4611-8d3f-335c2416175b
 480 ;;; assistant.el ends here