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-previous-node-text (node)
 174   (format "<< Go back to %s" node))
 175
 176 (defun assistant-next-node-text (node)
 177   (if (and node
 178            (not (eq node 'finish)))
 179       (format "Proceed to %s >>" node)
 180     "Finish"))
 181
 182 (defun assistant-set-defaults (node &optional forcep)
 183   (dolist (variable (assistant-get-list node "variable"))
 184     (setq variable (cadr variable))
 185     (when (or (eq (nth 3 variable) 'default)
 186               forcep)
 187       (setcar (nthcdr 3 variable)
 188               (assistant-eval (nth 2 variable))))))
 189
 190 (defun assistant-get-variable (node variable &optional type raw)
 191   (let ((variables (assistant-get-list node "variable"))
 192         (result nil)
 193         elem)
 194     (while (and (setq elem (pop variables))
 195                 (not result))
 196       (setq elem (cadr elem))
 197       (when (eq (intern variable) (car elem))
 198         (if type
 199             (setq result (nth 1 elem))
 200           (setq result (if raw (nth 3 elem)
 201                          (format "%s" (nth 3 elem)))))))
 202     result))
 203
 204 (defun assistant-set-variable (node variable value)
 205   (let ((variables (assistant-get-list node "variable"))
 206         elem)
 207     (while (setq elem (pop variables))
 208       (setq elem (cadr elem))
 209       (when (eq (intern variable) (car elem))
 210         (setcar (nthcdr 3 elem) value)))))
 211
 212 (defun assistant-render-text (text node)
 213   (dolist (elem text)
 214     (if (stringp elem)
 215         ;; Ordinary text
 216         (insert elem)
 217       ;; A variable to be inserted as a widget.
 218       (let* ((start (point))
 219              (variable (cadr elem))
 220              (type (assistant-get-variable node variable 'type)))
 221         (cond
 222          ((eq (car-safe type) :set)
 223           (push
 224            (apply
 225             #'widget-create
 226             'checklist
 227             :assistant-variable variable
 228             :assistant-node node
 229             :value (assistant-get-variable node variable)
 230             :notify (lambda (widget &rest ignore)
 231                       (assistant-set-variable
 232                        (widget-get widget :assistant-node)
 233                        (widget-get widget :assistant-variable)
 234                        (widget-value widget))
 235                       (assistant-render-node
 236                        (assistant-get
 237                         (widget-get widget :assistant-node)
 238                         "node")))
 239             (cadr type))
 240            assistant-widgets))
 241          ((eq (car-safe type) :radio)
 242           (push
 243            (apply
 244             #'widget-create
 245             'radio-button-choice
 246             :assistant-variable variable
 247             :assistant-node node
 248             :value (assistant-get-variable node variable)
 249             :notify (lambda (widget &rest ignore)
 250                       (assistant-set-variable
 251                        (widget-get widget :assistant-node)
 252                        (widget-get widget :assistant-variable)
 253                        (widget-value widget))
 254                       (assistant-render-node
 255                        (assistant-get
 256                         (widget-get widget :assistant-node)
 257                         "node")))
 258             (cadr type))
 259            assistant-widgets))
 260          (t
 261           (push
 262            (widget-create
 263             'editable-field
 264             :value-face 'assistant-field-face
 265             :assistant-variable variable
 266             (assistant-get-variable node variable))
 267            assistant-widgets)
 268           ;; The editable-field widget apparently inserts a newline;
 269           ;; remove it.
 270           (delete-char -1)
 271           (add-text-properties start (point)
 272                                (list
 273                                 'bold t
 274                                 'face 'assistant-field-face
 275                                 'not-read-only t))))))))
 276
 277 (defun assistant-render-node (node-name)
 278   (let ((node (assistant-find-node node-name))
 279         (inhibit-read-only t)
 280         (previous assistant-current-node)
 281         (buffer-read-only nil))
 282     (set (make-local-variable 'assistant-widgets) nil)
 283     (assistant-set-defaults node)
 284     (if (equal (assistant-get node "type") "interstitial")
 285         (assistant-render-node (assistant-find-next-node node-name))
 286       (setq assistant-current-node node-name)
 287       (when previous
 288         (push previous assistant-previous-nodes))
 289       (erase-buffer)
 290       (insert (cadar assistant-data) "\n\n")
 291       (insert node-name "\n\n")
 292       (assistant-render-text (assistant-get node "text") node)
 293       (insert "\n\n")
 294       (when assistant-previous-nodes
 295         (assistant-node-button 'previous (car assistant-previous-nodes)))
 296       (widget-create
 297        'push-button
 298        :assistant-node node-name
 299        :notify (lambda (widget &rest ignore)
 300                  (let* ((node (widget-get widget :assistant-node)))
 301                    (assistant-set-defaults (assistant-find-node node) 'force)
 302                    (assistant-render-node node)))
 303        "Reset")
 304       (insert " ")
 305       (assistant-node-button 'next (assistant-find-next-node))
 306       (insert "\n")
 307       (goto-char (point-min))
 308       (assistant-make-read-only))))
 309
 310 (defun assistant-make-read-only ()
 311   (let ((start (point-min))
 312         end)
 313     (while (setq end (text-property-any start (point-max) 'not-read-only t))
 314       (put-text-property start end 'read-only t)
 315       (put-text-property start end 'rear-nonsticky t)
 316       (while (get-text-property end 'not-read-only)
 317         (incf end))
 318       (setq start end))
 319     (put-text-property start (point-max) 'read-only t)))
 320
 321 (defun assistant-node-button (type node)
 322   (let ((text (if (eq type 'next)
 323                   (assistant-next-node-text node)
 324                 (assistant-previous-node-text node))))
 325     (widget-create
 326      'push-button
 327      :assistant-node node
 328      :assistant-type type
 329      :notify (lambda (widget &rest ignore)
 330                (let* ((node (widget-get widget :assistant-node))
 331                       (type (widget-get widget :assistant-type)))
 332                  (if (eq type 'previous)
 333                      (progn
 334                        (setq assistant-current-node nil)
 335                        (pop assistant-previous-nodes))
 336                    (assistant-get-widget-values)
 337                    (assistant-validate))
 338                  (if (null node)
 339                      (assistant-finish)
 340                    (assistant-render-node node))))
 341      text)
 342     (use-local-map widget-keymap)))
 343
 344 (defun assistant-validate-types (node)
 345   (dolist (variable (assistant-get-list node "variable"))
 346     (setq variable (cadr variable))
 347     (let ((type (nth 1 variable))
 348           (value (nth 3 variable)))
 349       (when
 350           (cond
 351            ((eq type :number)
 352             (string-match "[^0-9]" value))
 353            (t
 354             nil))
 355         (error "%s is not of type %s: %s"
 356                (car variable) type value)))))
 357
 358 (defun assistant-get-widget-values ()
 359   (let ((node (assistant-find-node assistant-current-node)))
 360     (dolist (widget assistant-widgets)
 361       (assistant-set-variable
 362        node (widget-get widget :assistant-variable)
 363        (widget-value widget)))))
 364
 365 (defun assistant-validate ()
 366   (let* ((node (assistant-find-node assistant-current-node))
 367          (validation (assistant-get node "validate"))
 368          result)
 369     (assistant-validate-types node)
 370     (when validation
 371       (when (setq result (assistant-eval validation))
 372         (unless (y-or-n-p (format "Error: %s.  Continue? " result))
 373           (error "%s" result))))
 374     (assistant-set node "save" t)))
 375
 376 (defun assistant-find-next-node (&optional node)
 377   (let* ((node (assistant-find-node (or node assistant-current-node)))
 378          (nexts (assistant-get-list node "next"))
 379          next elem)
 380     (while (and (setq elem (cadr (pop nexts)))
 381                 (not next))
 382       (when (setq next (assistant-eval (car elem)))
 383         (setq next (or (cadr elem) next))))
 384     next))
 385
 386 (defun assistant-get-all-variables ()
 387   (let ((variables nil))
 388     (dolist (node (cdr assistant-data))
 389       (setq variables
 390             (append (assistant-get-list node "variable")
 391                     variables)))
 392     variables))
 393
 394 (defun assistant-eval (form)
 395   (let ((bindings nil))
 396     (dolist (variable (assistant-get-all-variables))
 397       (setq variable (cadr variable))
 398       (push (list (car variable) (if (eq (nth 3 variable) 'default)
 399                                      nil
 400                                    (nth 3 variable)))
 401             bindings))
 402     (eval
 403      `(let ,bindings
 404         ,form))))
 405
 406 (defun assistant-finish ()
 407   (let ((results nil)
 408         result)
 409     (dolist (node (cdr assistant-data))
 410       (when (assistant-get node "save")
 411         (setq result (assistant-get node "result"))
 412         (push (list (car result)
 413                     (assistant-eval (cadr result)))
 414               results)))
 415     (message "Results: %s"
 416              (nreverse results))))
 417
 418 ;;; Validation functions.
 419
 420 (defun assistant-validate-connect-to-server (server port)
 421   (let* ((error nil)
 422          (stream
 423           (condition-case err
 424               (open-network-stream "nntpd" nil server port)
 425             (error (setq error err)))))
 426     (if (and (processp stream)
 427              (memq (process-status stream) '(open run)))
 428         (progn
 429           (delete-process stream)
 430           nil)
 431       error)))
 432
 433 (defun assistant-authinfo-data (server port type)
 434   (when (file-exists-p "~/.authinfo")
 435     (netrc-get (netrc-machine (netrc-parse "~/.authinfo")
 436                               server port)
 437                (if (eq type 'user)
 438                    "login"
 439                  "password"))))
 440
 441 (defun assistant-password-required-p ()
 442   nil)
 443
 444 (provide 'assistant)
 445
 446 ;;; arch-tag: 0404bfa2-9226-4611-8d3f-335c2416175b
 447 ;;; assistant.el ends here