home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / dmacro-2.0 / dmacro-bld.el < prev    next >
Encoding:
Text File  |  1991-11-15  |  14.8 KB  |  536 lines
  1. ;;; Copyright (c) 1991 Wayne Mesard.  May be redistributed only under the
  2. ;;; terms of the GNU Emacs General Public License.
  3.  
  4. ;;; 
  5. ;;; DMACRO-BLD  :  Dynamic MACRO BuiLDer
  6. ;;;
  7.  
  8. ;;; COMMANDS
  9. ;;    build-dmacro
  10. ;;    dmacro-build-command    Control-c Control-c
  11. ;;    dmacro-build-modfiers    Control-c Control-m
  12. ;;    write-dmacro-file
  13.  
  14. ;;; HISTORY
  15. ;;    2.0 wmesard - Oct 31, 1991: Created.
  16.  
  17. ;;; AUTHOR
  18. ;;    Wayne Mesard, WMesard@Oracle.com
  19.  
  20. ;;; BUGS
  21. ;;    - No way to re-edit an existing dmacro. -wsm9/4/91.
  22. ;;    - If you enter a prompt item, then cursor back and enter another 
  23. ;;      reference to that prompt (by hitting return to take the default)
  24. ;;      it will screw up during expansion since the ~(prompt) command will
  25. ;;      appear before the ~(prompt item "Enter item: ").  The workaround
  26. ;;      is to make sure that the first prompt reference you enter is the
  27. ;;      first one that occurs in the dmacro text.
  28. ;;    - No way to apply multiple modifier lists.  E.g., can't use
  29. ;;      build-dmacro to get the first char of the last word:
  30. ;;      (((<foo>) :sexp -1) 0 1)
  31.  
  32. ;;;
  33. ;;; REQUIREMENTS
  34. ;;;
  35.  
  36. (require 'dmacro)
  37.  
  38.  
  39. ;;; 
  40. ;;; KEY BINDINGS
  41. ;;; 
  42.  
  43. (if (not (and (boundp 'dont-bind-my-keys) dont-bind-my-keys))
  44.     (progn
  45.       (global-set-key "\C-c\C-d" 'dmacro-build-command)
  46.       (global-set-key "\C-c\C-m" 'dmacro-build-modfiers)
  47.       ))
  48.  
  49. ;;; 
  50. ;;; PUBLIC VARIABLES
  51. ;;; 
  52.  
  53. (defvar dmacro-build-mode nil "Non-nil if \\[build-dmacro] is active.")
  54.  
  55. (setq minor-mode-alist 
  56.       (cons '(dmacro-build-mode " Dmacro") minor-mode-alist))
  57.  
  58.  
  59. ;;; 
  60. ;;; PRIVATE VARIABLES
  61. ;;; 
  62.  
  63. ;; If you create a dmacro function (via DEF-DMACRO-FUNCTION) that takes
  64. ;; arguments, you can add lambda expression to DMACRO-BUILD-ARG-FUNCS
  65. ;; that will prompt the user for the arguments and return them as a list.
  66. ;;   See dmacro-build-get-cmd for details.
  67.  
  68. (defconst dmacro-build-arg-funcs
  69.   (list
  70.    '(prompt . dmacro-build-prompt)
  71.    (cons 'eval
  72.      (function (lambda (arglist)
  73.              (list
  74.               (dmacro-read-mb "Sexp to be evaled: " (car arglist)))
  75.              )))
  76.    '(if . dmacro-build-if)
  77.    (cons 'insert-file
  78.      (function (lambda (arglist)
  79.              (list (read-file-name "File to insert: "))
  80.              )))
  81.    (cons 'shell
  82.      (function (lambda (arglist)
  83.              (list (dmacro-read-string "Shell command to execute: "
  84.                          (car arglist)))
  85.              )))
  86.    (cons 'dmacro
  87.      (function (lambda (arglist)
  88.              (list
  89.               (dmacro-minibuffer-read "Dmacro to insert: " t)
  90.               (y-or-n-p "Leave point in inserted dmacro? "))
  91.              )))
  92.    ))
  93.  
  94.  
  95.  
  96. ;; Used to hold the list of commands during dmacro construction.
  97. ;; Each item is of the form (end-mark cmd string [mods]).
  98. ;; Unbound when a dmacro is not in progress.
  99. (defvar dmacro-build-marks)
  100.  
  101. ;;; 
  102. ;;; COMMANDS
  103. ;;; 
  104.  
  105. (defun build-dmacro (global)
  106.   "Interactively build a new dmacro.
  107. With a prefix arg, the dmacro will be global, otherwise it is defined
  108. for the current major mode.  You will be prompted for the dmacro
  109. name and the documentation string.  Then a recursive edit is invoked in
  110. which you specify the text and commands for the new dmacro.
  111. Use \\[dmacro-build-command] to insert a command; \\[exit-recursive-edit] when done; \\[abort-recursive-edit] to abort the definition."
  112.   (interactive "P")
  113.   (if dmacro-build-mode
  114.       (error 
  115.        (substitute-command-keys "Dmacro construction already in progress. Type \\[exit-recursive-edit] when done. \\[abort-recursive-edit] to abort.")))
  116.   (let* ((textbeg (point-marker))
  117.      (abbrevtab (if (or global only-global-abbrevs (not local-abbrev-table))
  118.             global-abbrev-table
  119.               local-abbrev-table))
  120.      (temname
  121.       (let ((candidate nil))
  122.         (while (or (null candidate)
  123.                (and (abbrev-symbol candidate abbrevtab)
  124.                 (not (y-or-n-p "Redefine existing dmacro? "))))
  125.           (setq candidate (dmacro-minibuffer-read 
  126.                    (if global 
  127.                    "Name of new global dmacro: "
  128.                  (concat "Name of new dmacro for "
  129.                       mode-name
  130.                       " mode: "))
  131.                    nil))
  132.           )
  133.         candidate))
  134.      (doc (read-string "Documentation: " 
  135.                (cdr (assq (abbrev-symbol temname abbrevtab)
  136.                       dmacro-doclist))))
  137.      (dmacro-build-marks nil)
  138.      (dmacro-build-mode t)
  139.      (dmacro-point nil)
  140.      (dmacro-last-prompt 'your-text)
  141.      textend)
  142.     (message
  143.      (substitute-command-keys 
  144.       "Build macro. Type \\[dmacro-build-command] to insert directive. \\[exit-recursive-edit] when done."))
  145.     (recursive-edit)
  146.     ;; Set the marker one after point, so we don't have to worry about
  147.     ;; overrunning it. (This could happen if the dmacro ends in a commmand
  148.     ;; (because the prin1 wil insert the text after the marker).)
  149.     (if (/= (point) (point-max))
  150.     (setq textend (set-marker (make-marker) (1+ (point)))))
  151.     ;; Replace each cmd text with its dmacro command (if the text is
  152.     ;; still there).
  153.     (while dmacro-build-marks
  154.       (let* ((item (car dmacro-build-marks))
  155.          (end (marker-position (car item)))
  156.          (len (length (nth 2 item)))
  157.          (beg (- end len)))
  158.     (if (string= (buffer-substring beg end)
  159.              (nth 2 item))
  160.         (progn
  161.           (delete-region beg end)
  162.           (goto-char beg)
  163.           (insert "~")
  164.           (prin1 
  165.            (if (nth 3 item)
  166.            (cons (nth 1 item)
  167.              (nth 3 item))
  168.          (nth 1 item))
  169.            (current-buffer))
  170.            ))
  171.     ;; Null the marker so it doesn't so down editing.
  172.     (set-marker (car item) nil)
  173.     )
  174.       (setq dmacro-build-marks (cdr dmacro-build-marks))
  175.       )
  176.     (setq textend (if textend
  177.               (1- textend)
  178.             (point-max)))
  179.     (let* ((text (buffer-substring textbeg textend))
  180.        (hook (if (save-excursion (goto-char textbeg)
  181.                      (re-search-forward "^\\s-" textend t))
  182.              'dmacro-indent))
  183.        )
  184.       (if (zerop (length doc))
  185.       (setq doc nil))
  186.       (define-dmacro abbrevtab temname text hook doc)
  187.       )
  188.     (delete-region textbeg textend)
  189.     (let ((dmacro-prompt nil))    ; Don't prompt this time.
  190.       (insert-dmacro temname)
  191.       )
  192.   (message "%s%s%s"
  193.        "Dmacro \""
  194.        temname
  195.        (substitute-command-keys 
  196.         "\" defined. Type \\[write-dmacro-file] to save new dmacros."))
  197.   ))
  198.  
  199.  
  200. (defun dmacro-build-command ()
  201.   "Insert a Dmacro command while \\[build-dmacro] is active.
  202. Prompts for function name and any arguments."
  203.   (interactive)
  204.   (dmacro-build-check-active)
  205.   (dmacro-build-add-item (dmacro-build-command-1 "Dmacro command: "))
  206.   ;; This command is so silly looking so that the key description comes out
  207.   ;; as "C-c C-m" instead of "C-c RET".
  208.   (message "%s%s%s"
  209.        "Command added to dmacro. Type "
  210.        (if (eq 'dmacro-build-modfiers (key-binding "\C-c\C-m"))
  211.            "C-c C-m"
  212.          (substitute-command-keys "\\[dmacro-build-modfiers]"))
  213.        " to add modifiers."))
  214.  
  215.  
  216.  
  217. (defun dmacro-build-modfiers ()
  218.   "Apply modifiers to a Dmacro command (when \\[build-dmacro] is
  219. active).  The cursor should be positioned on or immediately after the
  220. text of the command that you wish to modify.  Prompts for the
  221. modifiers."
  222.   (interactive)
  223.   (dmacro-build-check-active)
  224.   (let ((item (or (dmacro-build-find-cmd (point))
  225.           ;; If point isn't on a command, maybe it's one
  226.           ;; char after one
  227.           (if (> (point) (point-min))
  228.               (dmacro-build-find-cmd (1- (point))))
  229.           (error "Point not in a dmacro command.")))
  230.     (newmods (dmacro-build-get-mods)))
  231.     ;; delete the text from the buffer and the item from the list
  232.     (goto-char (car item))
  233.     (delete-char (- (length (nth 2 item))))
  234.     (set-marker (car item) nil)
  235.     (setq dmacro-build-marks (delq item dmacro-build-marks))
  236.     (dmacro-build-add-item (dmacro-build-run (nth 1 item) newmods))
  237.     (message "Modifiers applied.")
  238.     ))
  239.  
  240.  
  241. (defun write-dmacro-file (file)
  242.   "Save all dmacros to FILE.  This creates a Dmacro file 
  243. suitable for further modification by a qualified Dmacro programmer,
  244. or loading from your ~/.emacs file."
  245.   (interactive "FWrite dmacro file: ")
  246.   (set-buffer (get-buffer-create " dmacro-temp"))
  247.   (erase-buffer)
  248.   (insert "(require 'dmacro)\n\n")
  249.   (mapcar (function insert-dmacro-table-description) abbrev-table-name-list)
  250.   (write-region (point-min) (point-max) file)
  251.   (erase-buffer))
  252.  
  253. ;;; 
  254. ;;; PRIVATE FUNCTIONS
  255. ;;; 
  256.  
  257.  
  258. (defun dmacro-build-prompt (arglist)
  259.   (let* ((sym (dmacro-read-mb 
  260.            (concat "Item name [default: " 
  261.                (symbol-name dmacro-last-prompt)
  262.                "]: ")
  263.            (car arglist)))
  264.      (string (if sym
  265.              (dmacro-read-string 
  266.               (concat 
  267.                "String to prompt the user [default: \""
  268.                (capitalize (symbol-name sym))
  269.                ": \"]: ")
  270.               (nth 1 arglist))))
  271.      (reader (if string
  272.              (dmacro-read-mb 
  273.               "Prompter function [default: read-string]: "
  274.               (nth 2 arglist))))
  275.      (args (if reader
  276.            (dmacro-read-mb
  277.             "List of other args to prompter: "
  278.             (nthcdr 3 arglist)
  279.             t)))
  280.      )
  281.     (append
  282.      (if sym (list sym))
  283.      (if string (list string))
  284.      (if reader (list reader))
  285.      args)
  286.     ))
  287.  
  288.  
  289. (defun dmacro-build-if (arglist)
  290.   (let*
  291.       ((expr 
  292.     (dmacro-build-command-1 "Conditional function: "))
  293.        (then 
  294.     (if (char-equal ?s (dmacro-build-read-char
  295.                 "THEN command: (S)tring (F)unction: "
  296.                 '(?s ?f)))
  297.         (dmacro-read-string "THEN string: "
  298.                   (if (stringp (nth 1 arglist))
  299.                       (nth 1 arglist)))
  300.       (dmacro-build-command-1 "THEN function: ")))
  301.        (elsetype 
  302.     (dmacro-build-read-char "ELSE command: (S)tring (F)unction (N)one: "
  303.                   '(?s ?f ?n)))
  304.        (else
  305.     (if (char-equal ?s elsetype)
  306.         (dmacro-read-string "ELSE string: "
  307.                   (if (stringp (nth 2 arglist))
  308.                       (nth 2 arglist)))
  309.       (if (char-equal ?f elsetype)
  310.           (dmacro-build-command-1 "ELSE function: ")))
  311.     ))
  312.     (if else
  313.     (list expr then else)
  314.       (list expr then))
  315.     ))
  316.  
  317. (defun dmacro-build-check-active ()
  318.   (if (null dmacro-build-mode)
  319.       (error "No dmacro being constructed.")
  320.     ))
  321.  
  322.  
  323. ;; Like read-minibuffer except INITIAL is a sexp not a string,
  324. ;; and nil is returned if the user doesn't enter anything.
  325. ;; If NILCOUNTSP is non-nil, then INITIAL is used even if it's nil.
  326. ;; If NILCOUNTSP is t, then "()" is used.  If NILCOUNTSP is non-nil but
  327. ;; not t, "nil" is used.
  328.  
  329. (defun dmacro-read-mb (prompt &optional initial nilcountsP)
  330.   (condition-case nil
  331.       (read-minibuffer prompt 
  332.                (if (or nilcountsP initial)
  333.                (if (and (null initial) (eq t nilcountsP))
  334.                    "()"
  335.                  (prin1-to-string initial)))
  336.                )
  337.     (error nil)))
  338.  
  339.  
  340. ;; Like read-string except nil is returned if the user doesn't enter anything.
  341.  
  342. (defun dmacro-read-string (prompt &optional initial)
  343.   (let ((res (read-string prompt initial)))
  344.     (if (zerop (length res))
  345.     nil
  346.       res)))
  347.  
  348.  
  349. ;; Takes a prompt and a list of legal chars which must be all lowercase.
  350. ;; Prompts the user until one of the chars in the list (or it's uppercase
  351. ;; equivalent is entered.
  352.  
  353. (defun dmacro-build-read-char (prompt charlist)
  354.   (let ((ch nil)
  355.     (echo-keystrokes 0))
  356.     (while (null ch)
  357.       (message prompt)
  358.       (setq ch (downcase (read-char)))
  359.       (if (not (memq ch charlist))
  360.       (progn
  361.         (setq ch nil)
  362.         (beep t))
  363.     ))
  364.     ch))
  365.  
  366.  
  367. ;; Returns: (cmd result-string)
  368. (defun dmacro-build-command-1 (prompt)
  369.   (dmacro-build-get-cmd (intern-soft 
  370.                (completing-read prompt 
  371.                         (mapcar (function 
  372.                              (lambda (x) 
  373.                                (list 
  374.                             (symbol-name (car x))
  375.                             )))
  376.                             dmacro-functions)
  377.                         nil t nil))
  378.               ))
  379.  
  380.  
  381.  
  382.  
  383.  
  384. ;; itemlist is a list of the form (cmd result-string [mods])
  385. ;; as returned by dmacro-build-run via some other function.
  386.  
  387. (defun dmacro-build-add-item (itemlist)
  388.   (insert (car (cdr itemlist)))
  389.   ;; (end-mark cmd result-string [mods])
  390.   ;; Where "cmd" is (funcname args...) or ((funcname args...) modifiers)
  391.   (setq dmacro-build-marks
  392.     (cons
  393.      (cons (point-marker) itemlist)
  394.      dmacro-build-marks))
  395.   )
  396.  
  397.  
  398. (defun dmacro-build-find-cmd (loc)
  399.   (let ((lis dmacro-build-marks)
  400.     (item nil))
  401.     (while (and lis (null item))
  402.       (let ((endpos (car (car lis))))
  403.     (if (and (< loc endpos)
  404.          (>= loc (- endpos (length (nth 2 (car lis)))))
  405.          (string= (nth 2 (car lis)) 
  406.               (buffer-substring 
  407.                (- endpos (length (nth 2 (car lis))))
  408.                endpos)))
  409.         (setq item (car lis))
  410.       ))
  411.       (setq lis (cdr lis))
  412.       )
  413.     item))
  414.  
  415.  
  416. (defun dmacro-build-get-mods ()
  417.   (let ((ch t)
  418.     case pad sexpP beg end)
  419.     (while ch
  420.       (setq ch (dmacro-build-read-char
  421.         "Modifiers: (U)pper (L)ower (C)aps (P)ad (S)ubstring (E)xpression.  Or Return"
  422.         '(?u ?l ?c ?p ?s ?e ?\r)))
  423.       (cond ((= ?\r ch)
  424.          (setq ch nil))
  425.         ((let ((newcase (assq ch '((?u . :up)(?l . :down)(?c . :cap)))))
  426.            (if newcase
  427.            (setq case (cdr newcase))))
  428.          (message "Added case modifier."))
  429.         ((= ?p ch)
  430.          (message "Character for left-padding [default: no padding]: ")
  431.          (setq pad (read-char))
  432.          (if (char-equal ?\r pad)
  433.          (setq pad nil))
  434.          (if pad
  435.          (message "Text will be left-padded with: %c" pad)
  436.            (message "Text will be left-trimmed (i.e., no leading whitespace)")))
  437.         ((= ?e ch)
  438.          (setq sexpP t)
  439.          (message "Substring args will now count by expressions instead of characters.")
  440.          (sit-for 1 t))
  441.         ((= ?s ch)
  442.          (setq beg nil)
  443.          (while (null beg)
  444.            (setq beg (dmacro-read-mb "Substring start: "))
  445.            (if (not (integerp beg))
  446.            (progn
  447.              (setq beg nil)
  448.              (beep t))
  449.          ))
  450.          (setq end t)
  451.          (while (eq t end)
  452.            (setq end
  453.              (dmacro-read-mb 
  454.               "Substring end (Return for end of string): "))
  455.            (if (not (or (null end) (integerp beg)))
  456.            (progn
  457.              (setq beg t)
  458.              (beep t))
  459.          ))
  460.          (message "Added substring modifier: %s %s." beg end))
  461.         ((beep t)
  462.          (message "Illegal command."))
  463.         )
  464.       (if ch (sit-for 1 t))
  465.       )
  466.     (append
  467.      (if case (list case))
  468.      (if pad (list ':pad pad))
  469.      (if sexpP (list ':sexp))
  470.      (if beg (list beg end)))
  471.     ))
  472.  
  473.  
  474. (defun dmacro-build-get-cmd (name)
  475.   (let ((getter (cdr (assq name dmacro-build-arg-funcs)))
  476.     (cmd nil)
  477.     arglist)
  478.     (while (not cmd)
  479.       (if getter
  480.       (setq arglist (funcall getter arglist))
  481.     )
  482.       (setq cmd
  483.         (condition-case err
  484.         (dmacro-build-run (cons name arglist) nil)
  485.           (error
  486.            ;; If there were user-specified args, show the user the error.
  487.            (if arglist
  488.            (progn
  489.              (beep t)
  490.              (message (prin1-to-string err))
  491.              (sit-for 2)
  492.              ))
  493.            (if (null getter)
  494.            ;; If there was an error, and we didn't prompt for any args
  495.            ;; that could be the problem, so do it now:
  496.            (setq arglist
  497.              (dmacro-read-mb 
  498.               (concat "Arglist for " 
  499.                   (symbol-name name) ": ") arglist t))
  500.          )
  501.            nil))
  502.         ))
  503.     cmd))
  504.  
  505.  
  506. (defun dmacro-build-run (cmd mods)
  507.   (let* (dmacro-ts
  508.      dmacro-fn
  509.      (string (dmacro-run (dmacro-parse cmd nil (list mods)))))
  510.     (list cmd 
  511.       (if (zerop (length string))
  512.           "<>"
  513.         string)
  514.       mods)
  515.     ))
  516.  
  517.  
  518. (defun insert-dmacro-table-description (tabname)
  519.   (insert "(add-dmacros '" (symbol-name tabname) " '(\n")
  520.   (mapatoms
  521.    (function (lambda (x)
  522.            (if (assq x dmacro-doclist)
  523.            (progn
  524.              (insert " ")
  525.              (prin1 (list (symbol-name x)
  526.                   (symbol-value x)
  527.                   (symbol-function x)
  528.                   (cdr (assq x dmacro-doclist)))
  529.                 (current-buffer))
  530.              (insert "\n")
  531.              ))
  532.            ))
  533.    (symbol-value tabname))
  534.   (insert "))\n\n")
  535.   )
  536.