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

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