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 (defvar assistant-readers
  32   '(("variable" assistant-variable-reader)
  33     ("validate" assistant-sexp-reader)
  34     ("result" assistant-list-reader)
  35     ("next" assistant-list-reader)))
  36
  37 ;;; Internal variables
  38
  39 (defvar assistant-data nil)
  40 (defvar assistant-current-node nil)
  41 (defvar assistant-previous-node nil)
  42
  43 (defun assistant-parse-buffer ()
  44   (let (results command value)
  45     (goto-char (point-min))
  46     (while (search-forward "@" nil t)
  47       (if (not (looking-at "[^ \t\n]+"))
  48           (error "Dangling @")
  49         (setq command (downcase (match-string 0)))
  50         (goto-char (match-end 0)))
  51       (setq value
  52             (if (looking-at "[ \t]*\n")
  53                 (let (start)
  54                   (forward-line 1)
  55                   (setq start (point))
  56                   (unless (re-search-forward (concat "^@end " command) nil t)
  57                     (error "No @end %s found" command))
  58                   (beginning-of-line)
  59                   (prog1
  60                       (buffer-substring start (point))
  61                     (forward-line 1)))
  62               (skip-chars-forward " \t")
  63               (prog1
  64                   (buffer-substring (point) (line-end-position))
  65                 (forward-line 1))))
  66       (push (list command (assistant-reader command value))
  67             results))
  68     (assistant-segment (nreverse results))))
  69
  70 ;; Segment the raw assistant data into a list of nodes.
  71 (defun assistant-segment (list)
  72   (let ((ast nil)
  73         (node nil)
  74         (title (pop list)))
  75     (dolist (elem list)
  76       (when (and (equal (car elem) "node")
  77                  node)
  78         (push (list "save" nil) node)
  79         (push (nreverse node) ast)
  80         (setq node nil))
  81       (push elem node))
  82     (when node
  83       (push (list "save" nil) node)
  84       (push (nreverse node) ast))
  85     (cons title (nreverse ast))))
  86
  87 (defun assistant-reader (command value)
  88   (let ((formatter (cadr (assoc command assistant-readers))))
  89     (if (not formatter)
  90         value
  91       (funcall formatter value))))
  92
  93 (defun assistant-list-reader (value)
  94   (car (read-from-string (concat "(" value ")"))))
  95
  96 (defun assistant-variable-reader (value)
  97   (let ((section (car (read-from-string (concat "(" value ")")))))
  98     (append section (list 'default))))
  99
 100 (defun assistant-sexp-reader (value)
 101   (if (zerop (length value))
 102       nil
 103     (car (read-from-string value))))
 104
 105 (defun assistant-buffer-name (title)
 106   (format "*Assistant %s*" title))
 107
 108 (defun assistant-get (ast command)
 109   (cadr (assoc command ast)))
 110
 111 (defun assistant-set (ast command value)
 112   (let ((elem (assoc command ast)))
 113     (when elem
 114       (setcar (cdr elem) value))))
 115
 116 (defun assistant-get-list (ast command)
 117   (let ((result nil))
 118     (dolist (elem ast)
 119       (when (equal (car elem) command)
 120         (push elem result)))
 121     (nreverse result)))
 122
 123 (defun assistant (file)
 124   "Assist setting up Emacs based on FILE."
 125   (interactive "fAssistant file name: ")
 126   (let ((ast
 127          (with-temp-buffer
 128            (insert-file-contents file)
 129            (assistant-parse-buffer))))
 130     (pop-to-buffer (assistant-buffer-name (assistant-get ast "title")))
 131     (assistant-render ast)))
 132
 133 (defun assistant-render (ast)
 134   (let ((first-node (assistant-get (nth 1 ast) "node")))
 135     (set (make-local-variable 'assistant-data) ast)
 136     (set (make-local-variable 'assistant-current-node) first-node)
 137     (set (make-local-variable 'assistant-previous-node) nil)
 138     (assistant-render-node first-node)))
 139
 140 (defun assistant-find-node (node-name)
 141   (let ((ast (cdr assistant-data)))
 142     (while (and ast
 143                 (not (string= node-name (assistant-get (car ast) "node"))))
 144       (pop ast))
 145     (car ast)))
 146
 147 (defun assistant-previous-node-text (node)
 148   (format "[ << Go back to %s ]  " node))
 149
 150 (defun assistant-next-node-text (node)
 151   (if node
 152       (format "[ Proceed to %s >> ]" node)
 153     "[ Finish ]"))
 154
 155 (defun assistant-set-defaults (node)
 156   (dolist (variable (assistant-get-list node "variable"))
 157     (setq variable (cadr variable))
 158     (when (eq (nth 3 variable) 'default)
 159       (setcar (nthcdr 3 variable)
 160               (eval (nth 2 variable))))))
 161
 162 (defun assistant-render-node (node-name)
 163   (let ((node (assistant-find-node node-name)))
 164     (assistant-set-defaults node)
 165     (setq assistant-current-node node-name)
 166     (erase-buffer)
 167     (insert (cadar assistant-data) "\n\n")
 168     (insert node-name "\n\n")
 169     (insert (assistant-get node "text") "\n\n")
 170     (when assistant-previous-node
 171       (assistant-node-button 'previous assistant-previous-node))
 172     (assistant-node-button 'next (assistant-find-next-node))
 173     (insert "\n")))
 174
 175 (defun assistant-node-button (type node)
 176   (let ((text (if (eq type 'next)
 177                   (assistant-next-node-text node)
 178                 (assistant-previous-node-text node))))
 179     (widget-create
 180      'push-button
 181      :assistant-node node
 182      :assistant-type type
 183      :notify (lambda (widget &rest ignore)
 184                (let* ((node (widget-get widget :assistant-node))
 185                       (type (widget-get widget :assistant-type)))
 186                  (when (eq type 'next)
 187                    (assistant-validate))
 188                  (if (null node)
 189                      (assistant-finish)
 190                    (assistant-render-node node))))
 191      text)
 192     (use-local-map widget-keymap)))
 193
 194 (defun assistant-validate-types (node)
 195   (dolist (variable (assistant-get-list node "variable"))
 196     (setq variable (cadr variable))
 197     (let ((type (nth 1 variable))
 198           (value (nth 3 variable)))
 199       (when
 200           (cond
 201            ((eq type :number)
 202             (not (numberp value)))
 203            (t
 204             nil))
 205         (error "%s is not of type %s: %s"
 206                (car variable) type value)))))
 207
 208 (defun assistant-validate ()
 209   (let* ((node (assistant-find-node assistant-current-node))
 210          (validation (assistant-get node "validate"))
 211          result)
 212     (assistant-validate-types node)
 213     (when validation
 214       (when (setq result (assistant-eval validation node))
 215         (unless (y-or-n-p (format "Error: %s.  Continue? " result))
 216           (error "%s" result))))
 217     (assistant-set node "save" t)))
 218
 219 (defun assistant-find-next-node ()
 220   (let* ((node (assistant-find-node assistant-current-node))
 221          (nexts (assistant-get-list node "next"))
 222          next elem)
 223     (while (and (setq elem (pop nexts))
 224                 (not next))
 225       (when (assistant-eval (car elem) node)
 226         (setq next (cadr elem))))
 227     next))
 228
 229 (defun assistant-eval (form node)
 230   (let ((bindings nil))
 231     (dolist (variable (assistant-get-list node "variable"))
 232       (setq variable (cadr variable))
 233       (push (list (car variable) (nth 3 variable))
 234             bindings))
 235     (eval
 236      `(let ,bindings
 237         ,form))))
 238
 239 (defun assistant-finish ()
 240   (let ((results nil)
 241         result)
 242     (dolist (node (cdr assistant-data))
 243       (when (assistant-get node "save")
 244         (setq result (assistant-get node "result"))
 245         (push (list (car result)
 246                     (assistant-eval (cadr result) node))
 247               results)))
 248     (message "Results: %s"
 249              (nreverse results))))
 250
 251 (provide 'assistant)