diff options
Diffstat (limited to 'generic')
32 files changed, 15572 insertions, 0 deletions
diff --git a/generic/README b/generic/README new file mode 100644 index 00000000..4cf61435 --- /dev/null +++ b/generic/README @@ -0,0 +1,15 @@ +Proof General + +The code in this directory implements the generic basis +of Proof General. + +It was written by Thomas Kleymann, Dilip Sequeira, Healfdene Goguen, +David Aspinall, and Markus Wenzel. + +Several other people helped with contributions and modifications, see +individual credits in the code or summary in the Proof General manual. + +Contributions to the generic basis are welcome! + +$Id$ + diff --git a/generic/_pkg.el b/generic/_pkg.el new file mode 100644 index 00000000..97a893ec --- /dev/null +++ b/generic/_pkg.el @@ -0,0 +1,4 @@ +;;;###autoload +(package-provide 'ProofGeneral + :version "3.3pre010320" + :type 'regular) diff --git a/generic/pg-assoc.el b/generic/pg-assoc.el new file mode 100644 index 00000000..8e73fd48 --- /dev/null +++ b/generic/pg-assoc.el @@ -0,0 +1,107 @@ +;; pg-assoc.el Functions for associated buffers +;; +;; Copyright (C) 1994-2002 LFCS Edinburgh. +;; Authors: David Aspinall, Yves Bertot, Healfdene Goguen, +;; Thomas Kleymann and Dilip Sequeira +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; + +;; A sub-module of proof-shell; assumes proof-script loaded. +(require 'proof-script) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Defines an empty mode inherited by modes of the associated buffers. +;; + +(eval-and-compile +(define-derived-mode proof-universal-keys-only-mode fundamental-mode + proof-general-name "Universal keymaps only" + ;; Doesn't seem to supress TAB, RET + (suppress-keymap proof-universal-keys-only-mode-map 'all) + (proof-define-keys proof-universal-keys-only-mode-map + proof-universal-keys))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Manipulating prover output +;; + +(defun pg-assoc-strip-subterm-markup (string) + "Return STRING with subterm and pbp annotations removed. +Special annotations are characters with codes higher than +'pg-subterm-first-special-char'. +If pg-subterm-first-special-char is unset, return STRING unchanged." + (if pg-subterm-first-special-char + (let* ((ip 0) (op 0) (l (length string)) (out (make-string l ?x ))) + (while (< ip l) + (if (>= (aref string ip) pg-subterm-first-special-char) + (if (and pg-subterm-start-char + (char-equal (aref string ip) pg-subterm-start-char)) + (progn (incf ip) + ;; da: this relies on annotations being + ;; characters between \200 and first special + ;; char (e.g. \360). Why not just look for + ;; the sep char?? + (while + (< (aref string ip) + pg-subterm-first-special-char) + (incf ip)))) + (aset out op (aref string ip)) + (incf op)) + (incf ip)) + (substring out 0 op)) + string)) + +(defun pg-assoc-strip-subterm-markup-buf (start end) + "Remove subterm and pbp annotations from region." + ;; FIXME: create these regexps ahead of time. + (if pg-subterm-start-char + (let ((ann-regexp + (concat + (regexp-quote (char-to-string pg-subterm-start-char)) + "[^" + (regexp-quote (char-to-string pg-subterm-sep-char)) + "]*" + (regexp-quote (char-to-string pg-subterm-sep-char))))) + (save-restriction + (narrow-to-region start end) + (goto-char start) + (proof-replace-regexp ann-regexp "") + (goto-char start) + (proof-replace-string (char-to-string pg-subterm-end-char) "") + (goto-char start) + (if pg-topterm-char + (proof-replace-string (char-to-string pg-topterm-char) "")))))) + + +(defun pg-assoc-strip-subterm-markup-buf-old (start end) + "Remove subterm and pbp annotations from region." + (let (c) + (goto-char start) + (while (< (point) end) + ;; FIXME: small OBO here: if char at end is special + ;; it won't be removed. + (if (>= (setq c (char-after (point))) + pg-subterm-first-special-char) + (progn + (delete-char 1) + (decf end) + (if (char-equal c pg-subterm-start-char) + (progn + ;; FIXME: could simply replace this by replace + ;; match, matching on sep-char?? + (while (and (< (point) end) + (< (char-after (point)) + pg-subterm-first-special-char)) + (delete-char 1) + (decf end))))) + (forward-char))) + end)) + + + +(provide 'pg-assoc) +;; pg-assoc.el ends here. diff --git a/generic/pg-goals.el b/generic/pg-goals.el new file mode 100644 index 00000000..45a3b8a0 --- /dev/null +++ b/generic/pg-goals.el @@ -0,0 +1,392 @@ +;; pg-goals.el Proof General goals buffer mode. +;; +;; Copyright (C) 1994-2002 LFCS Edinburgh. +;; Authors: David Aspinall, Yves Bertot, Healfdene Goguen, +;; Thomas Kleymann and Dilip Sequeira +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; + +;; A sub-module of proof-shell; assumes proof-script loaded. + +(require 'pg-assoc) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Goals buffer mode +;; + +;; +;; The mode itself +;; +(eval-and-compile ; to define proof-goals-mode-map +(define-derived-mode proof-goals-mode proof-universal-keys-only-mode + proof-general-name + "Mode for goals display. +May enable proof-by-pointing or similar features. +\\{proof-goals-mode-map}" + (setq proof-buffer-type 'goals) + ;; font-lock-keywords isn't automatically buffer-local in Emacs 21.2 + (make-local-variable 'font-lock-keywords) + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'pg-save-from-death nil t) + (easy-menu-add proof-goals-mode-menu proof-goals-mode-map) + (easy-menu-add proof-assistant-menu proof-goals-mode-map) + (proof-toolbar-setup) + (erase-buffer) + (buffer-disable-undo) + (set-buffer-modified-p nil))) + +;; +;; Keys for goals buffer +;; +(define-key proof-goals-mode-map [q] 'bury-buffer) +(cond +(proof-running-on-XEmacs +(define-key proof-goals-mode-map [(button2)] 'pg-goals-button-action) +(define-key proof-goals-mode-map [(control button2)] 'proof-undo-and-delete-last-successful-command) +;; button 2 is a nuisance on 2 button mice, so we'll do 1 as well. +;; Actually we better hadn't, people like to use it for cut and paste. +;; (define-key proof-goals-mode-map [(button1)] 'pg-goals-button-action) +;; (define-key proof-goals-mode-map [(control button1)] 'proof-undo-and-delete-last-successful-command) +(define-key proof-goals-mode-map [(button3)] 'pg-goals-yank-subterm)) +(t +(define-key proof-goals-mode-map [mouse-2] 'pg-goals-button-action) +(define-key proof-goals-mode-map [C-mouse-2] 'proof-undo-and-delete-last-successful-command) +;; (define-key proof-goals-mode-map [mouse-1] 'pg-goals-button-action) +;; (define-key proof-goals-mode-map [C-mouse-1] 'proof-undo-and-delete-last-successful-command) +(define-key proof-goals-mode-map [mouse-3] 'pg-goals-yank-subterm))) + + +;; +;; Menu for goals buffer +;; +(easy-menu-define proof-goals-mode-menu + proof-goals-mode-map + "Menu for Proof General goals buffer." + proof-aux-menu) + + +;; +;; The completion of init +;; +(defun proof-goals-config-done () + "Initialise the goals buffer after the child has been configured." + (proof-font-lock-configure-defaults nil) + (proof-x-symbol-configure)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Goals buffer processing +;; +(defun pg-goals-display (string) + "Display STRING in the proof-goals-buffer, properly marked up. +Converts term substructure markup into mouse-highlighted extents, +and properly fontifies STRING using proof-fontify-region." + (save-excursion + ;; Response buffer may be out of date. It may contain (error) + ;; messages relating to earlier proof states + + ;; FIXME da: this isn't always the case. In Isabelle + ;; we get <WARNING MESSAGE> <CURRENT GOALS> output, + ;; or <WARNING MESSAGE> <ORDINARY MESSAGE>. Both times + ;; <WARNING MESSAGE> would be relevant. + ;; We should only clear the output that was displayed from + ;; the *previous* prompt. + + ;; Erase the response buffer if need be, maybe removing the + ;; window. Indicate it should be erased before the next output. + (proof-shell-maybe-erase-response t t) + + ;; Erase the goals buffer and add in the new string + (set-buffer proof-goals-buffer) + (erase-buffer) + ;; Only bother processing and displaying, etc, if string is + ;; non-empty. + (unless (string-equal string "") + (insert string) + + (if pg-use-specials-for-fontify + ;; With special chars for fontification, do that first, + ;; but keep specials in case also used for subterm markup. + (proof-fontify-region (point-min) (point-max) 'keepspecials)) + (pg-goals-analyse-structure (point-min) (point-max)) + + (unless pg-use-specials-for-fontify + ;; provers which use ordinary keywords to fontify output must + ;; do fontification second after subterm specials are removed. + (proof-fontify-region (point-min) (point-max))) + + ;; Record a cleaned up version of output string + (setq proof-shell-last-output + (buffer-substring (point-min) (point-max))) + + (set-buffer-modified-p nil) ; nicety + + ;; Keep point at the start of the buffer. + (proof-display-and-keep-buffer + proof-goals-buffer (point-min))))) + + +(defun pg-goals-analyse-structure (start end) + "Analyse the region between START and END for subterm and PBP markup. + +For subterms, we can make nested regions in the concrete syntax into +active mouse-highlighting regions, each of which can be used to +communicate a selected term back to the prover. The output text is +marked up with the annotation scheme: + + [ <annotation> | <subterm/concrete> ] + + ^ ^ ^ + | | | +pg-subterm-start-char pg-subterm-sep-char pg-subterm-end-char + +The annotation is intended to indicate a node in the abstract syntax +tree inside the prover, which can be used to pick out the internal +representation of the term itself. We assume that the annotation +takes the form of a sequence of characters: + + <length of shared prefix previous> <ann1> <ann2> .. <annN> + +Where each element <..> is a character which is *less* than +pg-subterm-first-special-char, but *greater* than 128. Each +character code has 128 subtracted to yield a number. The first +character allows a simple optimisation by sharing a prefix of +the previous (left-to-right) subterm's annotation. (See the +variable `pg-subterm-anns-use-stack' for an alternative +optimisation.) + +For subterm markup without communication back to the prover, the +annotation is not needed, but the first character must still be given. + +For proof-by-pointing (PBP) oriented markup, `pg-topterm-char' and +`pg-topterm-goalhyp-fn' should be set. Together these allow +further active regions to be defined, corresponding to \"top elements\" +in the proof-state display. A \"top element\" is currently assumed +to be either a hypothesis or a subgoal, and is assumed to occupy +a line (or at least a line). The markup is simply + + & <goal or hypthesis line in proof state> + ^ + | + pg-topterm-char + +And the function `pg-topterm-goalhyp-fn' is called to do the +further analysis, to return an indication of the goal/hyp and +record a name value. These values are used to construct PBP +commands which can be sent to the prover." + (if pg-subterm-start-char + (let* + ((cur start) + (len (- end start)) + (ann (make-string len ?x)) ; (more than) enough space for longest ann'n + (ap 0) + c stack topl span) + + (while (< cur end) + (setq c (char-after cur)) + (cond + ;; Seen goal char: this is the start of a top extent + ;; (assumption or goal) + ((= c pg-topterm-char) + (setq topl (cons cur topl)) + (setq ap 0)) + + ;; Seen subterm start char: it's followed by a char + ;; indicating the length of the annotation prefix + ;; which can be shared with the previous subterm. + ((= c pg-subterm-start-char) + (incf cur) + (if pg-subterm-anns-use-stack + (setq ap (- ap (- (char-after cur) 128))) + (setq ap (- (char-after cur) 128))) + (incf cur) + ;; Now search for a matching end-annotation char, recording the + ;; annotation found. + (while (not (= (setq c (char-after cur)) pg-subterm-sep-char)) + (aset ann ap (- c 128)) + (incf ap) + (incf cur)) + ;; Push the buffer pos and annotation + (setq stack (cons cur + (cons (substring ann 0 ap) stack)))) + + ;; Seen a subterm end char, terminating an annotated region + ;; in the concrete syntax. We make a highlighting span now. + ((and (consp stack) (= c pg-subterm-end-char)) + ;; (consp stack) added to make the code more robust. + ;; [ Condition violated with lego/example.l and GNU Emacs 20.3 ] + (setq span (make-span (car stack) cur)) + (set-span-property span 'mouse-face 'highlight) + (set-span-property span 'goalsave (cadr stack));; FIXME: 'goalsave? + ;; (set-span-property span 'balloon-help helpmsg) + (set-span-property span 'help-echo 'pg-goals-get-subterm-help) + (if pg-subterm-anns-use-stack + ;; Pop annotation off stack + (progn + (setq ap 0) + (while (< ap (length (cadr stack))) + (aset ann ap (aref (cadr stack) ap)) + (incf ap)))) + ;; Finish popping annotations + (setq stack (cdr (cdr stack))))) + ;; On to next char + (incf cur)) + + ;; List of topterm beginning positions (goals/hyps) found + (setq topl (reverse (cons end topl))) + + ;; Proof-by-pointing markup assumes "top" elements which define a + ;; context for a marked-up (sub)term: we assume these contexts to + ;; be either a subgoal to be solved or a hypothesis. + ;; Top element spans are only made if pg-topterm-goalhyp-fn is set. + ;; NB: If we want Coq pbp: (setq coq-current-goal 1) + (if pg-topterm-goalhyp-fn + (while (setq ap (car topl) + topl (cdr topl)) + (pg-goals-make-top-span ap (car topl)))) + + ;; Finally: strip the specials. This should + ;; leave the spans in exactly the right place. + (pg-assoc-strip-subterm-markup-buf start end)))) + + +(defun pg-goals-make-top-span (start end) + "Make a top span (goal/hyp area) for mouse active output." + (let (span typname) + (goto-char start) + ;; skip the pg-topterm-char itself + (forward-char) + ;; typname is expected to be a cons-cell of a type (goal/hyp) + ;; with a name, retrieved from the text immediately following + ;; the topterm-char annotation. + (setq typname (funcall pg-topterm-goalhyp-fn)) + (beginning-of-line) ;; any reason why? + (setq start (point)) + (goto-char end) + (beginning-of-line) + (backward-char) + (setq span (make-span start (point))) + (set-span-property span 'mouse-face 'highlight) + (set-span-property span 'proof-top-element typname))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Commands to prover based on subterm markup (inc PBP). +;; +;; + +;; Fairly specific to the mechanism implemented in LEGO +;; To make (more) sense of this code, you should read the +;; relevant LFCS tech report by tms, yb, and djs + +(defun pg-goals-yank-subterm (event) + "Copy the subterm indicated by the mouse-click EVENT. +This function should be bound to a mouse button in the Proof General +goals buffer. + +The EVENT is used to find the smallest subterm around a point. The +subterm is copied to the kill-ring, and immediately yanked (copied) +into the current buffer at the current cursor position. + +In case the current buffer is the goals buffer itself, the yank +is not performed. Then the subterm can be retrieved later by an +explicit yank." + (interactive "e") + (let (span) + (save-window-excursion + (save-excursion + (mouse-set-point event) + ;; Get either the proof body or whole goalsave + (setq span (or + (span-at (point) 'proof) + (span-at (point) 'goalsave))) + (if span (copy-region-as-kill + (span-start span) + (span-end span))))) + (if (and span (not (eq proof-buffer-type 'goals))) + (yank)))) + +(defun pg-goals-button-action (event) + "Construct a proof-by-pointing command based on the mouse-click EVENT. +This function should be bound to a mouse button in the Proof General +goals buffer. + +The EVENT is used to find the smallest subterm around a point. A +position code for the subterm is sent to the proof assistant, to ask +it to construct an appropriate proof command. The command which is +constructed will be inserted at the end of the locked region in the +proof script buffer, and immediately sent back to the proof assistant. +If it succeeds, the locked region will be extended to cover the +proof-by-pointing command, just as for any proof command the +user types by hand." + (interactive "e") + (mouse-set-point event) + (pg-goals-construct-command)) + +;; Using the spans in a mouse behavior is quite simple: from the mouse +;; position, find the relevant span, then get its annotation and +;; produce a piece of text that will be inserted in the right buffer. + +(defun proof-expand-path (string) + (let ((a 0) (l (length string)) ls) + (while (< a l) + (setq ls (cons (int-to-string + (char-to-int (aref string a))) + (cons " " ls))) + (incf a)) + (apply 'concat (nreverse ls)))) + +(defun pg-goals-construct-command () + ;; Examine the goals + (let* ((span (span-at (point) 'goalsave)) ;; goalsave means subgoal no/name + (top-span (span-at (point) 'proof-top-element)) + top-info) + (if (null top-span) () + (setq top-info (span-property top-span 'proof-top-element)) + (pop-to-buffer proof-script-buffer) + (cond + (span + (proof-shell-invisible-command + (format (if (eq 'hyp (car top-info)) pbp-hyp-command + pbp-goal-command) + (concat (cdr top-info) (proof-expand-path + (span-property span 'goalsave)))))) + ((eq (car top-info) 'hyp) + ;; Switch focus to another subgoal; a non-scripting command + (proof-shell-invisible-command + (format pbp-hyp-command (cdr top-info)))) + (t + (proof-insert-pbp-command + (format pg-goals-change-goal (cdr top-info)))))))) + + +(defun pg-goals-get-subterm-help (spanorwin &optional obj pos) + "Return a help string for subterm, called via 'help-echo property." + (let ((span (or obj spanorwin))) ;; GNU Emacs vs XEmacs interface + (if (and pg-subterm-help-cmd (span-live-p span)) + (or (span-property span 'cachedhelp) ;; already got + (progn + (if (proof-shell-available-p) + (let ((result + (proof-shell-invisible-cmd-get-result + (format pg-subterm-help-cmd (span-string span)) + 'ignorerrors))) + ;; FIXME: generalise, and make output readable + ;; (fontify? does that work for GNU Emacs? + ;; how can we do it away from a buffer?) + (setq result + (replace-in-string + result + (concat "\n\\|" pg-special-char-regexp) "")) + (set-span-property span 'cachedhelp result) + result))))))) + + + +(provide 'pg-goals) +;; pg-goals.el ends here. diff --git a/generic/pg-metadata.el b/generic/pg-metadata.el new file mode 100644 index 00000000..f8c3c67b --- /dev/null +++ b/generic/pg-metadata.el @@ -0,0 +1,112 @@ +;; pg-metadata.el Persistant storage of metadata for proof scripts +;; +;; Copyright (C) 2001-2 LFCS Edinburgh. +;; Author: David Aspinall <da@dcs.ed.ac.uk> +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; Status: incomplete; experimental +;; +;; TODO: +;; - add file dependency information to proof scripts individually +;; (can approximate from the transitive closure that is included files list) +;; + +(require 'pg-xml) + +;; Variables + +(defcustom pg-metadata-default-directory "~/.proofgeneral/" + "*Directory for storing metadata information about proof scripts." + :type 'file + :group 'proof-user-options) + +(defface proof-preparsed-span + (proof-face-specs + (:background "lightgoldenrodyellow") + (:background "darkgoldenrod") + (:underline t)) + "*Face for pre-parsed regions of proof script (unprocessed commands)." + :group 'proof-faces) + + +;; Utility functions + +(defun pg-metadata-filename-for (filename) + "Compute a revised FILENAME for storing corresponding metadata." + ;; We replace directory separators with double underscores. + ;; Clashes are possible, hopefully unlikely. + (concat + (file-name-as-directory pg-metadata-default-directory) + (replace-in-string + (file-name-sans-extension filename) + (regexp-quote (char-to-string directory-sep-char)) + "__") + ".pgm")) + + +;; Main code + +(defun pg-write-metadata-file (buffer) + "Write meta data for a script buffer BUFFER." + ;; FIXME: should check buffer has been saved + (if (buffer-file-name buffer) + (let* ((scriptfile (buffer-file-name buffer)) + (modtime (nth 5 (file-attributes scriptfile))) + (metadatafile (pg-metadata-filename-for scriptfile)) + (metadatabuf (find-file-noselect metadatafile 'nowarn)) + (span (span-at (point-min) 'type))) + type) + (pg-xml-begin-write) + (pg-xml-openelt 'script-file + (list (list 'filename scriptfile) + (list 'filedate modtime))) + (pg-xml-closeelt) + (while span + (let ((type (span-property span 'type)) + (name (span-property span 'name)) + (start (span-start span)) + (end (span-end span))) + (pg-xml-openelt + 'span + (list (list 'type type) + (list 'name name) + (list 'start start) + (list 'end end))) + ;; Include the span contents: can recover script file + ;; from this. (Could even display script using special + ;; display functions?) + (pg-xml-writetext (buffer-substring start end buffer)) + (pg-xml-closeelt)) + (setq span (next-span 'type))) + (with-current-buffer metadatabuf + (delete-region (point-min) (point-max)) + (insert (pg-xml-doc)) + (write-file metadatafile)))) + + +;(defun pg-read-metadata-file (buffer) +; "Read meta data for a script file BUFFER, and reconstitute spans. +;Spans are only reconstituted for positions after (proof-unprocessed-begin), +;and providing that the meta-data file is older than the script file." +; (if (buffer-file-name buffer) +; (let* ((scriptfile (buffer-file-name buffer)) +; (modtime (nth 5 (file-attributes scriptfile))) +; (metadatafile (pg-metadata-filename-for scriptfile)) +; (metadatabuf (find-file-noselect metadatafile 'nowarn)) +; (metadata (pg-xml-parse-buffer metadatabuf))) + +; (span (span-at (point-min) 'type))) +; type) + + +(provide 'pg-metadata) +;; pg-metadata.el ends here. + + + + + + +
\ No newline at end of file diff --git a/generic/pg-pgip.el b/generic/pg-pgip.el new file mode 100644 index 00000000..7ff79d00 --- /dev/null +++ b/generic/pg-pgip.el @@ -0,0 +1,326 @@ +;; pg-pgip.el Functions for processing PGIP for Proof General +;; +;; Copyright (C) 2000-2002 LFCS Edinburgh. +;; Author: David Aspinall <da@dcs.ed.ac.uk> +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; STATUS: Experimental +;; +;; Proof General Kit uses PGIP, an XML-message protocol +;; for interactive proof. This file contains functions +;; to process PGIP commands sent from the proof assistant. +;; + +;; Halt on errors during development: later may accumulate and ignore. +(defalias 'pg-pgip-error 'error) + +;;;###autoload +(defun pg-pgip-process-packet (pgip) + "Process the command packet PGIP, which is parsed XML according to pg-xml-parse-*" + ;; PGIP processing is split into two steps: + ;; (1) process each command, altering internal data structures + ;; (2) post-process for each command type, affecting external interface (menus, etc). + (mapcar 'pg-pgip-post-process + (pg-pgip-process-cmds pgip))) + +(defun pg-pgip-process-cmds (pgips) + "Process the command(s) in PGIP, returning list of command symbols processed." + (let (cmdtys) + (while pgips + (let* ((pgip (car pgips)) + (elt (or (car-safe (car pgip)) ; normalise to symbol + (car pgip))) + ;; FIXME: this is wrong for self-closing elts, test with + ;; ProofGeneral.process_pgip("<pgip><askpgml/></pgip>"); + (attr (cdr-safe (car pgip))) + (attrs (and attr (if (listp (cdr attr)) ; normalise to list + attr (list attr)))) + (body (cdr pgip))) + (add-to-list 'cmdtys elt) + (cond + ;; <pgip> + ((eq elt 'pgip)) ;; ignore pgip attributes for now + ;; <usespgml> + ((eq elt 'usespgml) + (proof-debug "Received usespgml message, version %s" + (pg-pgip-get-version "usespgml" attrs))) + ;; <haspref> + ((eq elt 'haspref) + (pg-pgip-haspref attrs (car-safe body))) + + ;; <prefval> + ((eq elt 'prefval) + (pg-pgip-prefval attrs (car-safe body))) + + ;; <idtable> + ((eq elt 'idtable) + ) + ;; <addid> + ((eq elt 'addid) + ) + ;; <delid> + ((eq elt 'delid) + ) + ;; <menuadd> + ((eq elt 'menuadd) + ) + ((eq elt 'menudel) + )) + ;; Move on to next element + (setq pgips (cdr pgips)))) + ;; Return list of command types processed. + cmdtys)) + +(defun pg-pgip-post-process (pgip) + "Perform post-processing for a PGIP command type PGIP-ELT." + (cond + ((eq pgip 'pgip)) + ((eq pgip 'usespgml)) + ((or + (eq pgip 'haspref) + (eq pgip 'prefval)) + ;; Update preferences view/menu + (proof-assistant-menu-update)) + ((or + (eq pgip 'idtable) + (eq pgip 'addid) + (eq pgip 'delid)) + ;; Update completion tables/view + ) + ((or + (eq pgip 'menuadd) + (eq pgip 'menudel)) + ;; Update menus + ))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; <haspref default="d" kind="k" type="t" +;; description="d" class="c">name</haspref> +;; +;; Proof assistant advises PG that it has a preference value named name, +;; category k, class c, with default value d, type t. +;; + +;; FIXME: PGIP requires prover to support <resetprefs/>, but this +;; could be done from interface, since default values are +;; advertised for preferences. + +(defun pg-pgip-haspref (attrs name) + "Issue a defpacustom from a <haspref> element with attributes ATTRS, name NAME." + (unless (stringp name) + (pg-pgip-error "pg-pgip-haspref: missing NAME in <haspref>NAME</haspref>.")) + (let* + ((type (pg-pgip-get-type attrs)) + (defattr (pg-pgip-get-attr "haspref" 'default attrs t)) + (default (if defattr + (pg-pgip-interpret-value defattr type) + (pg-pgip-default-for type))) + (kind (intern + (or + (pg-pgip-get-attr "haspref" 'kind attrs t) + ;; Default to kind user + "user"))) + (descr (or (pg-pgip-get-attr "haspref" 'descr attrs t) "")) + (subst (pg-pgip-subst-for type)) + (setting + (pg-prover-interpret-pgip-command + (concat "<pgip><setpref name=\"" name "\">" subst "</setpref></pgip>"))) + (symname (intern name))) ;; FIXME: consider Emacs ID normalising + (ignore-errors + ;; FIXME: allow rest of PGIP to be processed, would be better to + ;; accumulate errors somehow. + (proof-debug "haspref calling defpacustom: name:%s default:%s type:%s setting:%s" symname default type setting) + (eval + ;; FIXME: would like unique custom group for settings introduced by haspref. + ;; (preferences or something). + `(defpacustom ,symname ,default + (concat descr (if descr "\n") + "Setting configured by <haspref> PGIP message") + :type (quote ,type) + :setting ,setting))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; <prefval name="n">value</prefval> +;; +;; Proof assistant advises that preference n has been updated. +;; +;; Protocol is that <setpref> sent on a PGIP channel is assumed to +;; succeed, so is not required to be acknowledged with a <prefval> +;; message from prover. But no harm will result if it is --- and that +;; might be appropriate if some canonicalisation occurs. + +; in progress [FIXME: Isabelle can send this as reply to getpref now] +;(defun pg-pgip-prefval (attrs value) +; "Process a <prefval> element, by setting interface's copy of preference." +; (let* +; ((name (pg-pgip-get-attr "haspref" 'name attrs t)) +; (type ( + + + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Dealing with <pgiptype> +;; + +(defun pg-pgip-default-for (type) + "Synthesize a default value for type TYPE." + (cond + ((eq type 'boolean) nil) + ((eq type 'integer) 0) + ((eq type 'string) "") + ((eq (car-safe type) 'choice) + (car-safe (cdr-safe type))) + (t + (pg-pgip-error "pg-pgip-default-for: unrecognized type passed in")))) + +(defun pg-pgip-subst-for (type) + "Return a substitution string for type TYPE." + (cond + ((eq type 'boolean) "%b") + ((eq type 'integer) "%i") + (t "%s"))) + +(defun pg-pgip-get-type (attrs) + "Extract and check type value from ATTRS. Return type in internal (custom) format." + (let + ((rawtype (pg-pgip-get-attr "haspref" 'type attrs))) + (pg-pgip-pgiptype rawtype))) + + +(defun pg-pgip-pgiptype (rawtype) + "Return internal (custom format) representation for <pgiptype> element." + (cond + ((string-match "choice\(\\(.*\\)\)" rawtype) + (let* ((choiceslist (match-string 1 rawtype)) + ;; FIXME: nested choices not supported yet + (choices (split-string choiceslist "[ \f\t\n\r\v]*,[ \f\t\n\r\v]*"))) + (list 'choice (mapcar 'pg-pgip-pgiptype choices)))) + ((equal rawtype "boolean") + 'boolean) + ((equal rawtype "int") + 'integer) + ((equal rawtype "nat") ;; nat treated as int + 'integer) + ((equal rawtype "string") + 'string) + (t + (error "pg-pgip-pgiptype: unrecognized type %s" rawtype)))) + + +;; Converting PGIP representations to elisp representations. This is +;; the inverse of proof-assistant-format translations in proof-menu.el, +;; although we fix PGIP value syntax. + +(defun pg-pgip-interpret-bool (value) + (cond + ((string-equal value "true") t) + ((string-equal value "false") nil) + ;; Non-boolean value: return false, give debug message. + (t (progn + (proof-debug "pg-pgip-interpret-bool: received non-bool value %s" value) + nil)))) + +(defun pg-pgip-interpret-int (value) + ;; FIXME: string-to-int returns zero for non int string, + ;; should have better validation here. + (string-to-int value)) + +(defun pg-pgip-interpret-string (value) + value) + +(defun pg-pgip-interpret-choice (choices value) + ;; Untagged union types: test for each type in turn. + ;; FIXME: nested unions not supported here. + (cond + ((and + (memq 'boolean choices) + (or (string-equal value "true") (string-equal value "false"))) + (pg-pgip-interpret-value value 'boolean)) + ((and + (memq 'integer (cdr type)) + (string-match "[0-9]+$" value)) + (pg-pgip-interpret-value value 'integer)) + ((memq 'string (cdr type)) + ;; FIXME: No special syntax for string inside PGIP yet, should be? + (pg-pgip-interpret-value value 'string)) + (t + (pg-pgip-error "pg-pgip-interpret-choice: mismatching value %s for choices %s" + value choices)))) + +(defun pg-pgip-interpret-value (value type) + (cond + ((eq type 'boolean) + (pg-pgip-interpret-bool value)) + ((eq type 'integer) + (pg-pgip-interpret-int value)) + ((eq type 'string) + (pg-pgip-interpret-string value)) + ((and (consp type) (eq (car type) 'choice)) + (pg-pgip-interpret-choice (cdr type) value)) + (t + (pg-pgip-error "pg-pgip-interpret-value: unkown type %s" type)))) + +;;(defun pg-pgip-interpret-choice (value) +;; FIXME: Choice should be tagged. Syntax is <pgiptype>(value) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Auxiliary functions for parsing +;; + +(defun pg-pgip-get-attr (elt attrnm attrs &optional optional) + (let ((vrs (cdr-safe (assoc attrnm attrs)))) + (if optional + vrs + (or vrs + (error "Didn't find %s attribute in %s element" attrnm elt))))) + +(defun pg-pgip-get-version (elt attrs &optional optional) + (pg-pgip-get-attr elt "version" attrs optional)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Function to interface PGIP commands sent to prover. +;; +(defun pg-prover-interpret-pgip-command (pgip) + (cond + ((stringp proof-shell-issue-pgip-cmd) + (format proof-shell-issue-pgip-cmd pgip)) + ((functionp proof-shell-issue-pgip-cmd) + (funcall proof-shell-issue-pgip-cmd pgip)) + (t + ;; FIXME: Empty setting: might be better to send a comment + ""))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Sending PGIP commands to prover +;; + +(defun pg-issue-pgip (pgip &optional block) + (proof-shell-invisible-command + (funcall proof-shell-issue-pgip-cmd + (format "<pgip>%s</pgip>" pgip)) block)) + +;;;###autoload +(defun pg-pgip-askprefs () + (pg-issue-pgip "<askprefs/>" 'block)) + + +(provide 'pg-pgip) +;; End of `pg-pgip.el' diff --git a/generic/pg-response.el b/generic/pg-response.el new file mode 100644 index 00000000..4eb2fde0 --- /dev/null +++ b/generic/pg-response.el @@ -0,0 +1,340 @@ +;; pg-response.el Proof General response buffer mode. +;; +;; Copyright (C) 1994-2002 LFCS Edinburgh. +;; Authors: David Aspinall, Healfdene Goguen, +;; Thomas Kleymann and Dilip Sequeira +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; This mode is used for the response buffer proper, and +;; also the trace and theorems buffer. + + +;; A sub-module of proof-shell; assumes proof-script loaded. +(require 'pg-assoc) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Response buffer mode +;; + +(eval-and-compile +(define-derived-mode proof-response-mode proof-universal-keys-only-mode + "PGResp" "Responses from Proof Assistant" + (setq proof-buffer-type 'response) + ;; font-lock-keywords isn't automatically buffer-local in Emacs 21.2 + (make-local-variable 'font-lock-keywords) + (define-key proof-response-mode-map [q] 'bury-buffer) + (define-key proof-response-mode-map [c] 'pg-response-clear-displays) + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'pg-save-from-death nil t) + (easy-menu-add proof-response-mode-menu proof-response-mode-map) + (easy-menu-add proof-assistant-menu proof-response-mode-map) + (proof-toolbar-setup) + (setq pg-response-next-error nil) + (erase-buffer) + (buffer-disable-undo) + (set-buffer-modified-p nil))) + +(easy-menu-define proof-response-mode-menu + proof-response-mode-map + "Menu for Proof General response buffer." + proof-aux-menu) + + +(defun proof-response-config-done () + "Complete initialisation of a response-mode derived buffer." + (proof-font-lock-configure-defaults nil) + (proof-x-symbol-configure)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Multiple frames for goals and response buffers +;; +;; -- because who's going to bother do this by hand? +;; + +(defvar proof-shell-special-display-regexp nil + "Regexp for special-display-regexps for multiple frame use. +Internal variable, setting this will have no effect!") + +(defun proof-multiple-frames-enable () + (cond + (proof-multiple-frames-enable + (setq special-display-regexps + (union special-display-regexps + (list proof-shell-special-display-regexp))) + ;; If we're on XEmacs with toolbar, turn off toolbar and + ;; menubar for the small frames to save space. + ;; FIXME: this could be implemented more smoothly + ;; with property lists, and specifiers should perhaps be set + ;; for the frame rather than the buffer. Then could disable + ;; minibuffer, too. + ;; FIXME: add GNU Emacs version here. + (if (featurep 'toolbar) + (proof-map-buffers + (list proof-response-buffer proof-goals-buffer proof-trace-buffer) + (set-specifier default-toolbar-visible-p nil (current-buffer)) + ; (set-specifier minibuffer (minibuffer-window) (current-buffer)) + ;(set-specifier has-modeline-p nil (current-buffer)) + (remove-specifier has-modeline-p (current-buffer)) + (remove-specifier menubar-visible-p (current-buffer)) + ;; gutter controls buffer tab visibility in XE 21.4 + (and (boundp 'default-gutter-visible-p) + (remove-specifier default-gutter-visible-p (current-buffer))))) + ;; Try to trigger re-display of goals/response buffers, + ;; on next interaction. + ;; FIXME: would be nice to do the re-display here, rather + ;; than waiting for next re-display + (delete-other-windows + (if proof-script-buffer + (get-buffer-window proof-script-buffer t)))) + (t + ;; FIXME: would be nice to kill off frames automatically, + ;; but let's leave it to the user for now. + (setq special-display-regexps + (delete proof-shell-special-display-regexp + special-display-regexps))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Displaying in the response buffer +;; + +;; Flag and function to keep response buffer tidy. +(defvar pg-response-erase-flag nil + "Indicates that the response buffer should be cleared before next message.") + +(defun proof-shell-maybe-erase-response + (&optional erase-next-time clean-windows force) + "Erase the response buffer according to pg-response-erase-flag. +ERASE-NEXT-TIME is the new value for the flag. +If CLEAN-WINDOWS is set, use proof-clean-buffer to do the erasing. +If FORCE, override pg-response-erase-flag. + +If the user option proof-tidy-response is nil, then +the buffer is only cleared when FORCE is set. + +No effect if there is no response buffer currently. +Returns non-nil if response buffer was cleared." + (when (buffer-live-p proof-response-buffer) + (let ((doit (or (and + proof-tidy-response + (not (eq pg-response-erase-flag 'invisible)) + pg-response-erase-flag) + force))) + (if doit + (if clean-windows + (proof-clean-buffer proof-response-buffer) + ;; NB: useful optional arg to erase buffer is XEmacs specific, 8-(. + ;; (erase-buffer proof-response-buffer) + (with-current-buffer proof-response-buffer + (setq pg-response-next-error nil) ; all error msgs lost! + (erase-buffer) + (set-buffer-modified-p nil)))) + (setq pg-response-erase-flag erase-next-time) + doit))) + +(defun pg-response-display (str) + "Show STR as a response in the response buffer." + (unless pg-use-specials-for-fontify + (setq str (pg-assoc-strip-subterm-markup str))) + (proof-shell-maybe-erase-response t nil) + (pg-response-display-with-face str) + (proof-display-and-keep-buffer proof-response-buffer)) + +;; FIXME: this function should be combined with +;; proof-shell-maybe-erase-response-buffer. +(defun pg-response-display-with-face (str &optional face) + "Display STR with FACE in response buffer." + ;; 3.4: no longer return fontified STR, it wasn't used. + (cond + ((string-equal str "")) + ((string-equal str "\n")) ; quick exit, no display. + (t + (let (start end) + (with-current-buffer proof-response-buffer + ;; da: I've moved newline before the string itself, to match + ;; the other cases when messages are inserted and to cope + ;; with warnings after delayed output (non newline terminated). + (goto-char (point-max)) + ;; insert a newline before the new message unless the + ;; buffer is empty + (unless (eq (point-min) (point-max)) + (newline)) + (setq start (point)) + (insert str) + (unless (bolp) (newline)) + (setq end (proof-fontify-region start (point))) + ;; This is one reason why we don't keep the buffer in font-lock + ;; minor mode: it destroys this hacky property as soon as it's + ;; made! (Using the minor mode is much more convenient, tho') + (if (and face proof-output-fontify-enable) + (font-lock-append-text-property start end 'face face)) + ;; This returns the decorated string, but it doesn't appear + ;; decorated in the minibuffer, unfortunately. + ;; [ FIXME: users have asked for that to be fixed ] + ;; 3.4: remove this for efficiency. + ;; (buffer-substring start (point-max)) + (set-buffer-modified-p nil)))))) + + +(defun pg-response-clear-displays () + "Clear Proof General response and tracing buffers. +You can use this command to clear the output from these buffers when +it becomes overly long. Particularly useful when `proof-tidy-response' +is set to nil, so responses are not cleared automatically." + (interactive) + (proof-map-buffers (list proof-response-buffer proof-trace-buffer) + (erase-buffer) + (set-buffer-modified-p nil))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Next error function. +;; + +(defvar pg-response-next-error nil + "Error counter in response buffer to count for next error message.") + +;;;###autoload +(defun proof-next-error (&optional argp) + "Jump to location of next error reported in the response buffer. + +A prefix arg specifies how many error messages to move; +negative means move back to previous error messages. +Just C-u as a prefix means reparse the error message buffer +and start at the first error." + (interactive "P") + (if (and ;; At least one setting must be configured + pg-next-error-regexp + ;; Response buffer must be live + (or + (buffer-live-p proof-response-buffer) + (error "proof-next-error: no response buffer to parse!"))) + (let ((wanted-error (or (and (not (consp argp)) + (+ (prefix-numeric-value argp) + (or pg-response-next-error 0))) + (and (consp argp) 1) + (or pg-response-next-error 1))) + line column file errpos) + (set-buffer proof-response-buffer) + (goto-char (point-min)) + (if (re-search-forward pg-next-error-regexp + nil t wanted-error) + (progn + (setq errpos (save-excursion + (goto-char (match-beginning 0)) + (beginning-of-line) + (point))) + (setq line (match-string 2)) ; may be unset + (if line (setq line (string-to-int line))) + (setq column (match-string 3)) ; may be unset + (if column (setq column (string-to-int column))) + (setq pg-response-next-error wanted-error) + (if (and + pg-next-error-filename-regexp + ;; Look for the most recently mentioned filename + (re-search-backward + pg-next-error-filename-regexp nil t)) + (setq file + (if (file-exists-p (match-string 2)) + (match-string 2) + ;; May need post-processing to extract filename + (if pg-next-error-extract-filename + (format + pg-next-error-extract-filename + (match-string 2)))))) + ;; Now find the other buffer we need to display + (let* + ((errbuf + (if file + (find-file-noselect file) + (or proof-script-buffer + ;; We could make more guesses here, + ;; e.g. last script buffer active + ;; (keep a record of it?) + (error + "proof-next-error: can't guess file for error message")))) + (pop-up-windows t) + (rebufwindow + (or (get-buffer-window proof-response-buffer 'visible) + ;; Pop up a window. + (display-buffer proof-response-buffer)))) + ;; Make sure the response buffer stays where it is, + ;; and make sure source buffer is visible + (select-window rebufwindow) + (pop-to-buffer errbuf) + ;; Display the error message in the response buffer + (set-window-point rebufwindow errpos) + (set-window-start rebufwindow errpos) + ;; Find the error location in the error buffer + (set-buffer errbuf) + ;; FIXME: no handling of selective display here + (goto-line line) + (if (and column (> column 1)) + (move-to-column (1- column))))) + (setq pg-response-next-error nil) + (error "proof-next-error: couldn't find a next error."))))) + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Tracing buffers +;; + +;; An analogue of pg-response-display-with-face +(defun proof-trace-buffer-display (str) + "Display STR in the trace buffer." + (let (start) + (with-current-buffer proof-trace-buffer + (goto-char (point-max)) + (newline) + (setq start (point)) + (insert str) + (unless (bolp) (newline)) + (proof-fontify-region start (point)) + (set-buffer-modified-p nil)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Theorems buffer +;; +;; New in PG 3.5. +;; +;; Revives an old idea from Isamode: a buffer displaying a bunch +;; of theorem names. +;; + + +(defun pg-thms-buffer-clear () + "Clear the theorems buffer." + (with-current-buffer proof-thms-buffer + (goto-char (point-max)) + (newline) + (setq start (point)) + (insert str) + (unless (bolp) (newline)) + (proof-fontify-region start (point)) + (set-buffer-modified-p nil))) + + + + + + + + +(provide 'pg-response) +;; pg-response.el ends here. diff --git a/generic/pg-thymodes.el b/generic/pg-thymodes.el new file mode 100644 index 00000000..a709d0cb --- /dev/null +++ b/generic/pg-thymodes.el @@ -0,0 +1,93 @@ +;; pg-thymodes.el Proof General "theory" modes. +;; +;; Copyright (C) 2002 LFCS Edinburgh. +;; Author: David Aspinall +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; Functions for defining "theory" modes, i.e. modes for +;; non-interactive proof assistant files which do not contain proof +;; scripts. +;; +;; STATUS: in progress, experimental; needs macro debugging. + +(require 'proof) + + +;;;###autoload +(defmacro pg-defthymode (sym name &rest body) + "Define a Proof General mode for theory files. +Mode name is SYM-mode, named NAMED. BODY is the body of a setq and +can define a number of variables for the mode, viz: + + SYM-<font-lock-keywords> (value for font-lock-keywords) + SYM-<syntax-table-entries> (list of pairs: used for modify-syntax-entry calls) + SYM-<menu> (menu for the mode, arg of easy-menu-define) + SYM-<parent-mode> (defaults to fundamental-mode) + SYM-<filename-regexp> (regexp matching filenames for auto-mode-alist) + +All of these settings are optional." + (progn + (eval `(setq ,@body)) + (let* + ;; See what was defined + ((mode (intern (concat (symbol-name sym) "-mode"))) + (parentmode (pg-modesymval sym 'parent-mode 'fundamental-mode)) + (flks (pg-modesymval sym 'font-lock-keywords)) + (syntaxes (pg-modesymval sym 'syntax-table-entries)) + (menu (pg-modesymval sym 'menu)) + (menusym (pg-modesym sym 'menu)) + (keymap (pg-modesym mode 'map)) + (fileregexp (pg-modesymval sym 'filename-regexp))) + ;; Set auto-mode-alist + (if fileregexp + (setq auto-mode-alist + (cons (cons fileregexp mode) auto-mode-alist))) + ;; `(quote (list ,mode ,parentmode ,flks ,fileregexp))))) + ;; Define the mode (also makes keymap) + (eval + `(define-derived-mode ,mode ,parentmode ,name + (interactive) + (pg-do-unless-null ,flks (setq font-lock-keywords ,flks)) + (pg-do-unless-null ,syntaxes (mapcar 'modify-syntax-entry ,syntaxes)))) + ;; Define the menu (final value of macro to be evaluated) + `(pg-do-unless-null ,menu + `(easy-menu-define + ,menusym ,keymap + ,(concat "Menu for " + (symbol-name mode) + " defined by `pg-defthymode'.") + ,menu))))) + + + +;; Utilities + +(defmacro pg-do-unless-null (val &rest body) + `(if ,val + (progn ,@body))) + + +(defun pg-symval (sym &optional other) + "Return (symbol-value SYM) or nil/OTHER if SYM unbound." + (if (boundp sym) + (symbol-value sym) + other)) + +(defun pg-modesym (mode sym) + "Return MODE-SYM." + (intern (concat (symbol-name mode) "-" (symbol-name sym)))) + +(defun pg-modesymval (mode sym &optional other) + "Return value of symbol MODE-SYM or nil/OTHER if unbound." + (let ((modesym (pg-modesym mode sym))) + (if (boundp modesym) + (symbol-value modesym) + other))) + + + + +(provide 'pg-thymodes) +;; pg-thymodes.el ends here. diff --git a/generic/pg-user.el b/generic/pg-user.el new file mode 100644 index 00000000..146a5206 --- /dev/null +++ b/generic/pg-user.el @@ -0,0 +1,981 @@ +;; pg-user.el User level commands for Proof General +;; +;; Copyright (C) 2000-2002 LFCS Edinburgh. +;; Author: David Aspinall and others +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; + +(require 'proof-config) ; for proof-follow-mode + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; first a couple of helper functions +;; + +(defmacro proof-maybe-save-point (&rest body) + "Save point according to proof-follow-mode, execute BODY." + `(if (eq proof-follow-mode 'locked) + (progn + ,@body) + (save-excursion + ,@body))) + +(defun proof-maybe-follow-locked-end () + "Maybe point to the make sure the locked region is displayed." + (if (eq proof-follow-mode 'follow) + (proof-goto-end-of-queue-or-locked-if-not-visible))) + + +;; +;; Doing commands +;; + +(defun proof-assert-next-command-interactive () + "Process until the end of the next unprocessed command after point. +If inside a comment, just process until the start of the comment." + (interactive) + (proof-with-script-buffer + (proof-maybe-save-point + (goto-char (proof-queue-or-locked-end)) + (proof-assert-next-command)) + (proof-maybe-follow-locked-end))) + +(defun proof-process-buffer () + "Process the current (or script) buffer, and maybe move point to the end." + (interactive) + (proof-with-script-buffer + (proof-maybe-save-point + (goto-char (point-max)) + (proof-assert-until-point-interactive)) + (proof-maybe-follow-locked-end))) + + +;; +;; Undoing commands +;; + +(defun proof-undo-last-successful-command () + "Undo last successful command at end of locked region." + (interactive) + (proof-undo-last-successful-command-1)) + +(defun proof-undo-and-delete-last-successful-command () + "Undo and delete last successful command at end of locked region. +Useful if you typed completely the wrong command. +Also handy for proof by pointing, in case the last proof-by-pointing +command took the proof in a direction you don't like. + +Notice that the deleted command is put into the Emacs kill ring, so +you can use the usual `yank' and similar commands to retrieve the +deleted text." + (interactive) + (proof-undo-last-successful-command-1 'delete) + ;; FIXME want to do this here for 3.3, for nicer behaviour + ;; when deleting. + ;; Unfortunately nasty problem with read only flag when + ;; inserting at (proof-locked-end) sometimes behaves as if + ;; point is inside locked region (prob because span is + ;; [ ) and not [ ] -- why??). + ;; (proof-script-new-command-advance) + ) + +;; No direct key-binding for this one: C-c C-u was too dangerous, +;; when used quickly it's too easy to accidently delete! +(defun proof-undo-last-successful-command-1 (&optional delete) + "Undo last successful command at end of locked region. +If optional DELETE is non-nil, the text is also deleted from +the proof script." + (interactive "P") + (proof-with-script-buffer + (proof-maybe-save-point + (unless (proof-locked-region-empty-p) + (let ((lastspan (span-at-before (proof-locked-end) 'type))) + (if lastspan + (progn + (goto-char (span-start lastspan)) + (proof-retract-until-point delete)) + (error "Nothing to undo!"))))) + (proof-maybe-follow-locked-end))) + +(defun proof-retract-buffer () + "Retract the current buffer, and maybe move point to the start." + (interactive) + (proof-with-script-buffer + (proof-maybe-save-point + (goto-char (point-min)) + (proof-retract-until-point-interactive)) + (proof-maybe-follow-locked-end))) + +(defun proof-retract-current-goal () + "Retract the current proof, and move point to its start." + (interactive) + (proof-maybe-save-point + (let + ((span (proof-last-goal-or-goalsave))) + (if (and span (not (eq (span-property span 'type) 'goalsave)) + (< (span-end span) (proof-unprocessed-begin))) + (progn + (goto-char (span-start span)) + (proof-retract-until-point-interactive) + (proof-maybe-follow-locked-end)) + (error "Not proving"))))) + +;; +;; Interrupt +;; + +(defun proof-interrupt-process () + "Interrupt the proof assistant. Warning! This may confuse Proof General. +This sends an interrupt signal to the proof assistant, if Proof General +thinks it is busy. + +This command is risky because when an interrupt is trapped in the +proof assistant, we don't know whether the last command succeeded or +not. The assumption is that it didn't, which should be true most of +the time, and all of the time if the proof assistant has a careful +handling of interrupt signals." + (interactive) + (unless (proof-shell-live-buffer) + (error "Proof Process Not Started!")) + (unless proof-shell-busy + (error "Proof Process Not Active!")) + (with-current-buffer proof-shell-buffer + ;; Just send an interrrupt. + ;; Action on receiving one is triggered in proof-shell + (comint-interrupt-subjob) + (run-hooks 'proof-shell-pre-interrupt-hook))) + + +;; +;; Movement commands +;; + +;; FIXME da: the next function is messy. Also see notes in 'todo' +(defun proof-goto-command-start () + "Move point to start of current (or final) command of the script." + (interactive) + (let* ((cmd (span-at (point) 'type)) + (start (if cmd (span-start cmd)))) + (if start + (progn + ;; BUG: only works for unclosed proofs. + (goto-char start)) + (let ((semis (nth 1 (proof-segment-up-to (point) t)))) + (if (eq 'unclosed-comment (car-safe semis)) + (setq semis (cdr-safe semis))) + (if (nth 2 semis) ; fetch end point of previous command + (goto-char (nth 2 semis)) + ;; no previous command: just next to end of locked + (goto-char (proof-locked-end))))) + ;; Oddities of this function: if we're beyond the last proof + ;; command, it jumps back to the last command. Could alter this + ;; by spotting that command end of last of semis is before + ;; point. Also, behaviour with comments is different depending + ;; on whether locked or not. + (skip-chars-forward " \t\n"))) + +(defun proof-goto-command-end () + "Set point to end of command at point." + (interactive) + (let ((cmd (span-at (point) 'type))) + (if cmd (goto-char (span-end cmd)) +; (and (re-search-forward "\\S-" nil t) +; (proof-assert-until-point nil 'ignore-proof-process)) + (proof-assert-next-command nil + 'ignore-proof-process + 'dontmoveforward)) + (skip-chars-backward " \t\n") + (unless (eq (point) (point-min)) + ;; should land on terminal char + (backward-char)))) + + + +;; +;; Mouse functions +;; + +;; FIXME oddity here: with proof-follow-mode='locked, when retracting, +;; point stays where clicked. When advancing, it moves. Might +;; be nicer behaviour than actually moving point into locked region +;; which is only useful for cut and paste, really. +(defun proof-mouse-goto-point (event) + "Call proof-goto-point on the click position." + (interactive "e") + (proof-maybe-save-point + (mouse-set-point event) + (proof-goto-point))) + + +;; FIXME da: this is an oddity. It copies the span, but does not +;; send it, contrary to it's old name ("proof-send-span"). +;; Now made more general to behave like mouse-track-insert +;; when not over a span. +;; FIXME da: improvement would be to allow selection of part +;; of command by dragging, as in ordinary mouse-track-insert. +;; Maybe by setting some of the mouse track hooks. +(defun proof-mouse-track-insert (event) + "Copy highlighted command under the mouse to point. Ignore comments. +If there is no command under the mouse, behaves like mouse-track-insert." + (interactive "e") + (let ((str + (save-window-excursion + (save-excursion + (let* ((span (span-at (mouse-set-point event) 'type))) + (and + span + ;; Next test might be omitted to allow for non-script + ;; buffer copying (e.g. from spans in the goals buffer) + (eq (current-buffer) proof-script-buffer) + ;; Test for type=vanilla means that closed goal-save regions + ;; are not copied. + ;; PG 3.3: remove this test, why not copy full proofs? + ;; (wanted to remove tests for 'vanilla) + ;; (eq (span-property span 'type) 'vanilla) + ;; Finally, extracting the 'cmd part prevents copying + ;; comments, and supresses leading spaces, at least. + ;; Odd. + (span-property span 'cmd))))))) + ;; Insert copied command in original window, + ;; buffer, point position. + (if str + (insert str proof-script-command-separator) + (mouse-track-insert event)))) + + + + +;; +;; Minibuffer non-scripting command +;; + +(defvar proof-minibuffer-history nil + "History of proof commands read from the minibuffer") + +(defun proof-minibuffer-cmd (cmd) + "Prompt for a command in the minibuffer and send it to proof assistant. +The command isn't added to the locked region. + +If a prefix arg is given and there is a selected region, that is +pasted into the command. This is handy for copying terms, etc from +the script. + +If `proof-strict-state-preserving' is set, and `proof-state-preserving-p' +is configured, then the latter is used as a check that the command +will be safe to execute, in other words, that it won't ruin +synchronization. If when applied to the command it returns false, +then an error message is given. + +WARNING: this command risks spoiling synchronization if the test +`proof-state-preserving-p' is not configured, if it is +only an approximate test, or if `proof-strict-state-preserving' +is off (nil)." + (interactive + (list (read-string "Command: " + (if (and current-prefix-arg (region-exists-p)) + (replace-in-string + (buffer-substring (region-beginning) (region-end)) + "[ \t\n]+" " ")) + 'proof-minibuffer-history))) + (if (and proof-strict-state-preserving + proof-state-preserving-p + (not (funcall proof-state-preserving-p cmd))) + (error "Command is not state preserving, I won't execute it!")) + (proof-shell-invisible-command cmd)) + + +;; +;; Frobbing locked end +;; + +;; A command for making things go horribly wrong - it moves the +;; end-of-locked-region marker backwards, so user had better move it +;; correctly to sync with the proof state, or things will go all +;; pear-shaped. + +;; In fact, it's so risky, we'll disable it by default +(if (if proof-running-on-XEmacs + (get 'proof-frob-locked-end 'disabled t) + ;; FSF code more approximate + (not (member 'disabled (symbol-plist 'proof-frob-locked-end)))) + (put 'proof-frob-locked-end 'disabled t)) + +(defun proof-frob-locked-end () + "Move the end of the locked region backwards to regain synchronization. +Only for use by consenting adults. + +This command can be used to repair synchronization in case something +goes wrong and you want to tell Proof General that the proof assistant +has processed less of your script than Proof General thinks. + +You should only use it to move the locked region to the end of +a proof command." + (interactive) + (cond + (proof-shell-busy + (error "You can't use this command while %s is busy!" proof-assistant)) + ((not (eq (current-buffer) proof-script-buffer)) + (error "Must be in the active scripting buffer.")) + ;; Sometimes may need to move point forwards, when locked region + ;; is editable. + ;; ((> (point) (proof-locked-end)) + ;; (error "You can only move point backwards.")) + ;; FIXME da: should move to a command boundary, really! + (t (proof-set-locked-end (point)) + (delete-spans (proof-locked-end) (point-max) 'type)))) + + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; command history (unfinished) +;; +;; da: below functions for input history simulation are quick hacks. +;; Could certainly be made more efficient. + +;(defvar proof-command-history nil +; "History used by proof-previous-matching-command and friends.") + +;(defun proof-build-command-history () +; "Construct proof-command-history from script buffer. +;Based on position of point." +; ;; let +; ) + +;(defun proof-previous-matching-command (arg) +; "Search through previous commands for new command matching current input." +; (interactive)) +; ;;(if (not (memq last-command '(proof-previous-matching-command +; ;; proof-next-matching-command))) +; ;; Start a new search + +;(defun proof-next-matching-command (arg) +; "Search through following commands for new command matching current input." +; (interactive "p") +; (proof-previous-matching-command (- arg))) + +;; +;; end command history stuff +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Non-scripting proof assistant commands. +;;; + +;;; These are based on defcustom'd settings so that users may +;;; re-configure the system to their liking. + + +;; FIXME: da: add more general function for inserting into the +;; script buffer and the proof process together, and using +;; a choice of minibuffer prompting (hated by power users, perfect +;; for novices). +;; TODO: +;; Add named goals. +;; Coherent policy for movement here and elsewhere based on +;; proof-one-command-per-line user option. +;; Coherent policy for sending to process after writing into +;; script buffer. Could have one without the other. +;; For example, may be more easy to edit complex goal string +;; first in the script buffer. Ditto for tactics, etc. + + + +;; +;; Helper macros and functions +;; + +;; See put expression at end to give this indentation like while form +(defmacro proof-if-setting-configured (var &rest body) + "Give error if a configuration setting VAR is unset, otherwise eval BODY." + `(if ,var + (progn ,@body) + (error "Proof General not configured for this: set %s" + ,(symbol-name var)))) + +(defmacro proof-define-assistant-command (fn doc cmdvar &optional body) + "Define command FN to send string BODY to proof assistant, based on CMDVAR. +BODY defaults to CMDVAR, a variable." + `(defun ,fn () + ,(concat doc + (concat "\nIssues a command to the assistant based on " + (symbol-name cmdvar) ".") + "") + (interactive) + (proof-if-setting-configured ,cmdvar + (proof-shell-invisible-command ,(or body cmdvar))))) + +(defmacro proof-define-assistant-command-witharg (fn doc cmdvar prompt &rest body) + "Define command FN to prompt for string CMDVAR to proof assistant. +CMDVAR is a function or string. Automatically has history." + `(progn + (defvar ,(intern (concat (symbol-name fn) "-history")) nil + ,(concat "History of arguments for " (symbol-name fn) ".")) + (defun ,fn (arg) + ,(concat doc "\nIssues a command based on ARG to the assistant, using " + (symbol-name cmdvar) ".\n" + "The user is prompted for an argument.") + (interactive + (proof-if-setting-configured ,cmdvar + (if (stringp ,cmdvar) + (list (format ,cmdvar + (read-string + ,(concat prompt ": ") "" + ,(intern (concat (symbol-name fn) "-history"))))) + (funcall ,cmdvar)))) + ,@body))) + +(defun proof-issue-new-command (cmd) + "Insert CMD into the script buffer and issue it to the proof assistant. +If point is in the locked region, move to the end of it first. +Start up the proof assistant if necessary." + (proof-with-script-buffer + (if (proof-shell-live-buffer) + (if (proof-in-locked-region-p) + (proof-goto-end-of-locked t))) + (proof-script-new-command-advance) + ;; FIXME: fixup behaviour of undo here. Really want to temporarily + ;; disable undo for insertion. but (buffer-disable-undo) trashes + ;; whole undo list! + (insert cmd) + ;; FIXME: could do proof-indent-line here, but let's wait until + ;; indentation is fixed. + (proof-assert-until-point-interactive))) + +;; +;; Commands which do not require a prompt and send an invisible +;; command. +;; + +(proof-define-assistant-command proof-prf + "Show the current proof state." + proof-showproof-command) +(proof-define-assistant-command proof-ctxt + "Show the current context." + proof-context-command) +(proof-define-assistant-command proof-help + "Show a help or information message from the proof assistant. +Typically, a list of syntax of commands available." + proof-info-command) +(proof-define-assistant-command proof-cd + "Change directory to the default directory for the current buffer." + proof-shell-cd-cmd + (proof-format-filename proof-shell-cd-cmd + ;; FSF fix: use default-directory rather than fn + default-directory)) + +(defun proof-cd-sync () + "If proof-shell-cd-cmd is set, do proof-cd and wait for prover ready. +This is intended as a value for proof-activate-scripting-hook" + ;; The hook is set in proof-mode before proof-shell-cd-cmd may be set, + ;; so we explicitly test it here. + (if proof-shell-cd-cmd + (progn + (proof-cd) + (proof-shell-wait)))) + +;; +;; Commands which require an argument, and maybe affect the script. +;; + +;; FIXME: maybe move these to proof-menu + +(proof-define-assistant-command-witharg proof-find-theorems + "Search for items containing given constants." + proof-find-theorems-command + "Find theorems containing" + (proof-shell-invisible-command arg)) + +(proof-define-assistant-command-witharg proof-issue-goal + "Write a goal command in the script, prompting for the goal." + proof-goal-command + "Goal" + (let ((proof-one-command-per-line t)) ; Goals always start at a new line + (proof-issue-new-command arg))) + +(proof-define-assistant-command-witharg proof-issue-save + "Write a save/qed command in the script, prompting for the theorem name." + proof-save-command + "Save as" + (let ((proof-one-command-per-line t)) ; Saves always start at a new line + (proof-issue-new-command arg))) + + + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Electric terminator mode +;; +;; NB: only relevant for provers with a "terminal char" which +;; terminates commands in proof scripts. + +;; Register proof-electric-terminator as a minor mode. + +(deflocal proof-electric-terminator nil + "Fake minor mode for electric terminator.") + +(or (assq 'proof-electric-terminator minor-mode-alist) + (setq minor-mode-alist + (append minor-mode-alist + (list '(proof-electric-terminator + (concat " " proof-terminal-string)))))) + +;; This is a value used by custom-set property = proof-set-value. +(defun proof-electric-terminator-enable () + "Copy proof-electric-terminator-enable to all script mode copies of it. +Make sure the modeline is updated to display new value for electric terminator." + (if proof-mode-for-script + (proof-map-buffers (proof-buffers-in-mode proof-mode-for-script) + (setq proof-electric-terminator + proof-electric-terminator-enable))) + (redraw-modeline)) + +(proof-deftoggle proof-electric-terminator-enable proof-electric-terminator-toggle) + +(defun proof-electric-term-incomment-fn () + "Used as argument to proof-assert-until-point." + ;; CAREFUL: (1) dynamic scoping here + ;; (2) needs this name to be recognized in + ;; proof-assert-until-point + (setq incomment t) + (if ins (backward-delete-char 1)) + (goto-char mrk) + (insert proof-terminal-string)) + +;; FIXME da: this function is a mess and needs rewriting. +;; (proof-assert-until-point process needs cleaning up) +;; +;; What it should do: +;; * parse FIRST. If we're inside a comment or string, +;; then insert the terminator where we are. Otherwise +;; can skip backwards and insert the terminator at the +;; command end (perhaps optionally), and look for +;; existing terminator. + +(defun proof-process-electric-terminator () + "Insert the proof command terminator, and assert up to it. +This is a little bit clever with placement of semicolons, and will +try to avoid duplicating them in the buffer. +When used in the locked region (and so with strict read only off), it +always defaults to inserting a semi (nicer might be to parse for a +comment, and insert or skip to the next semi)." + (let ((mrk (point)) ins incomment) + (if (< mrk (proof-locked-end)) + ;; In locked region, just insert terminator without further ado + (insert proof-terminal-char) + ;; Otherwise, do other thing. + ;; Old idea: only shift terminator wildly if we're looking at + ;; whitespace. Why? + ;; (if (looking-at "\\s-\\|\\'\\|\\w") + (if (proof-only-whitespace-to-locked-region-p) + (error "There's nothing to do!")) + + (if (not (= (char-after (point)) proof-terminal-char)) + (progn + (forward-char) ;; immediately after command end. + (insert proof-terminal-string) + (setq ins t))) + (proof-assert-until-point 'proof-electric-term-incomment-fn) + (or incomment + (proof-script-next-command-advance))))) + +(defun proof-electric-terminator () + "Insert the terminator, perhaps sending the command to the assistant. +If proof-electric-terminator-enable is non-nil, the command will be +sent to the assistant." + (interactive) + (if proof-electric-terminator-enable + (proof-process-electric-terminator) + (self-insert-command 1))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Completion based on <PA>-completion-table +;; +;; Requires completion.el package. Completion is usually +;; a hand-wavy thing, so we don't make any attempt to maintain +;; a precise completion table or anything. +;; +;; New in 3.2. +;; +(defun proof-add-completions () + "Add completions from <PA>-completion-table to completion database. +Uses `add-completion' with a negative number of uses and ancient +last use time, to discourage saving these into the users database." + (interactive) + (require 'completion) + (mapcar (lambda (cmpl) + ;; completion gives error in this case; trapping + ;; the error here is tricky in FSF Emacs so duplicate + ;; the test. + (if (>= (length cmpl) completion-min-length) + (add-completion cmpl -1000 0))) + (proof-ass completion-table))) + +;; NB: completion table is expected to be set when proof-script +;; is loaded! Can call proof-script-add-completions if the table +;; is updated. +(eval-after-load "completion" + '(proof-add-completions)) + +(defun proof-script-complete (&optional arg) + "Like `complete' but case-fold-search set to proof-case-fold-search." + (interactive "*p") + (let ((case-fold-search proof-case-fold-search)) + (complete arg))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Tags table building +;; +;; New in 3.3... or perhaps later! +;; +;; FIXME: incomplete. Add function to build tags table from +;; + + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Function to insert last prover output in comment. +;; Requested/suggested by Christophe Raffalli +;; + +(defun pg-insert-last-output-as-comment () + "Insert the last output from the proof system as a comment in the proof script." + (interactive) + (if proof-shell-last-output + ;; There may be a system specific function to insert the comment + (if pg-insert-output-as-comment-fn + (pg-insert-output-as-comment-fn proof-shell-last-output) + ;; Otherwise the default behaviour is to use comment-region + (let ((beg (point)) end) + ;; pg-assoc-strip-subterm-markup: should be done + ;; for us in proof-fontify-region + (insert proof-shell-last-output) + ;; 3.4: add fontification. Questionable since comments will + ;; probably be re-highlighted, so colouration, especially + ;; based on removed specials, will be lost. + ;; X-Symbol conversion is useful, but a surprising nuisance + ;; to achieve, mainly because x-symbol doesn't give us back + ;; a useful pointer to end of region after converting, and + ;; character positions change. + ;; (FIXME: contact x-sym author about this). + ;; proof-fontify-region does this for us, now + (setq end (proof-fontify-region beg (point))) + (comment-region beg end))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Span manipulation +;; + +(defun pg-copy-span-contents (span) + "Copy contents of SPAN to kill ring, sans surrounding whitespace." + (copy-region-as-kill + (save-excursion + (goto-char (span-start span)) + (skip-chars-forward " \t\n") + (point)) + (save-excursion + (goto-char (span-end span)) + (skip-chars-backward " \t\n") + (point))) + (if (fboundp 'own-clipboard) ;; XEmacs function + (own-clipboard (car kill-ring)))) + +;; 3.3: these functions are experimental, in that they haven't +;; been rigorously tested. They don't work well in FSF Emacs. + +(defun pg-numth-span-higher-or-lower (span num &optional noerr) + "Find NUM'th span after/before SPAN. NUM is positive for after." + (unless (and span (<= (span-end span) (proof-unprocessed-begin))) + (if noerr + nil + (error "No processed region under point"))) + (let ((downflag (> num 0)) + (num (abs num)) + nextspan) + (while (and (> num 0) + (setq nextspan (if downflag + (next-span span 'type) + (prev-span span 'type))) + (if downflag + ;; If moving down, check we don't go beyond + ;; end of processed region + (<= (span-end span) (proof-unprocessed-begin)) + t)) + (setq num (1- num)) + (setq span nextspan)) + (if (= num 0) + span + (if noerr + nil + (error "No region to move past" num))))) + +(defun pg-control-span-of (span) + "Return the controlling span of SPAN, or SPAN itself." + (or (span-property span 'controlspan) + span)) + +;; Really a drag-and-drop interface for this would be nice. +(defun pg-move-span-contents (span num) + "Move SPAN up/downwards in the buffer, past NUM spans. +If NUM is negative, move upwards. Return new span." + ;; FIXME: maybe num arg is overkill, should only have 1? + (save-excursion + (let ((downflag (> num 0)) nextspan) + ;; Always move a control span instead; it contains + ;; children span which move together with it. + (setq span (pg-control-span-of span)) + (setq nextspan (pg-numth-span-higher-or-lower span num)) + ;; We're going to move the span to before/after nextspan. + ;; First make sure inserting there doesn't extend the span. + (if downflag + (set-span-property nextspan 'end-open t) + (set-span-property nextspan 'start-open t)) + ;; When we delete the span, we want to duplicate it + ;; to recreate in the new position. + (set-span-property span 'duplicable 't) + ;; FIXME: this is faulty: moving span up gives children + ;; list with single nil element. Hence liveness test + (mapcar (lambda (s) (if (span-live-p s) + (set-span-property s 'duplicable 't))) + (span-property span 'children)) + (let* ((start (span-start span)) + (end (span-end span)) + (contents (buffer-substring start end)) + ;; Locked end may move up when we delete + ;; region: we'll make sure to reset it + ;; again later, it shouldn't change. + ;; NB: (rely on singlethreadedness here, so + ;; lockedend doesn't move while in this code). + (lockedend (span-end proof-locked-span))) + (let ((inhibit-read-only t)) + ;; FIXME: undo behaviour isn't quite right yet. + (undo-boundary) + (delete-region start end) + (let ((insertpos (if downflag + (span-end nextspan) + (span-start nextspan)))) + (goto-char insertpos) + ;; Let XEmacs duplicate extents as needed, then repair + ;; their associations + (insert contents) + (let ((new-span + (span-at insertpos 'type)));should be one we deleted. + (set-span-property + new-span 'children + (append + (mapcar-spans 'pg-fixup-children-span + insertpos (point) 'type))) + (set-span-end proof-locked-span lockedend) + (undo-boundary) + new-span))))))) + +(defun pg-fixup-children-span (span) + (if (span-property span 'controlspan) + ;; WARNING: dynamic binding + (progn + (set-span-property span 'controlspan new-span) + (list span)))) + +(defun pg-move-region-down (&optional num) + "Move the region under point downwards in the buffer, past NUM spans." + (interactive "p") + (let ((span (span-at (point) 'type))) + (and span + (goto-char (span-start + (pg-move-span-contents span num))) + (skip-chars-forward " \t\n")))) + +(defun pg-move-region-up (&optional num) + "Move the region under point upwards in the buffer, past NUM spans." + (interactive "p") + (pg-move-region-down (- num))) + +;; FIXME: not working right yet, sigh... +(defun proof-forward-command (&optional num) + "Move forward to the start of the next proof region." + (interactive "p") + (skip-chars-forward " \t\n") + (let* ((span (or (span-at (point) 'type) + (and (skip-chars-backward " \t\n") + (> (point) (point-min)) + (span-at (1- (point)) 'type)))) + (nextspan (and span (pg-numth-span-higher-or-lower + (pg-control-span-of span) num 'noerr)))) + (cond + ((and nextspan (> num 0)) + (goto-char (span-start nextspan)) + (skip-chars-forward " \t\n")) + ((and nextspan (< num 0)) + (goto-char (span-end nextspan))) + ((and span (> num 0)) + (goto-char (span-end span))) + ((and span (< num 0)) + (goto-char (span-start span)))))) + +(defun proof-backward-command (&optional num) + (interactive "p") + (proof-forward-command (- num))) + + + + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Span menus and keymaps (maybe belongs in pg-menu) +;; + +(defvar pg-span-context-menu-keymap + (let ((map (make-sparse-keymap + "Keymap for context-sensitive menus on spans"))) + (cond + (proof-running-on-XEmacs + (define-key map [button3] 'pg-span-context-menu)) + (proof-running-on-Emacs21 + (define-key map [down-mouse-3] 'pg-span-context-menu))) + map)) + +;; FIXME: TODO here: +;; +;; Check for a 'type which is one of the elements we know about +;; (pgidioms). +;; + +(defun pg-span-for-event (event) + "Return span corresponding to position of a mouse click EVENT." + (cond + (proof-running-on-XEmacs + (select-window (event-window event)) + (span-at (event-point event) 'type)) + (proof-running-on-Emacs21 + (with-current-buffer + (window-buffer (posn-window (event-start event))) + (span-at (posn-point (event-start event)) 'type))))) + +(defun pg-span-context-menu (event) + (interactive "e") + (let ((span (pg-span-for-event event)) + cspan) + ;; Find controlling span + (while (setq cspan (span-property span 'controlspan)) + (setq span cspan)) + (let* + ((idiom (and span (span-property span 'idiom))) + (id (and span (span-property span 'id)))) + (popup-menu (pg-create-in-span-context-menu + span + (if idiom (symbol-name idiom)) + (if id (symbol-name id))))))) + +(defun pg-toggle-visibility () + "Toggle visibility of region under point." + (interactive) + (let* ((span (span-at (point) 'type)) + (idiom (and span (span-property span 'idiom))) + (id (and span (span-property span 'id)))) + (and idiom id + (pg-toggle-element-visibility (symbol-name idiom) (symbol-name id))))) + + +(defun pg-create-in-span-context-menu (span idiom name) + "Create the dynamic context-sensitive menu for a span." + ;; FIXME: performance here, consider caching in the span itself? + ;; (or maybe larger menu spans which are associated with a menu). + ;; FIXME: treat proof and non-proof regions alike, could add + ;; visibility controls for non-proof regions also, redesigning + ;; idiom notion. + (append + (list (pg-span-name span)) + (list (vector + "Show/hide" + (if idiom (list `pg-toggle-element-visibility idiom name) + idiom) + (not (not idiom)))) + (list (vector + "Copy" (list 'pg-copy-span-contents span) t)) + (if proof-experimental-features + (list (vector + "Move up" (list 'pg-move-span-contents span -1) + (pg-numth-span-higher-or-lower (pg-control-span-of span) -1 'noerr)))) + (if proof-experimental-features + (list (vector + "Move down" (list 'pg-move-span-contents span 1) + (pg-numth-span-higher-or-lower (pg-control-span-of span) 1 'noerr)))) + (if proof-script-span-context-menu-extensions + (funcall proof-script-span-context-menu-extensions span idiom name)) + (if (and proof-experimental-features + proof-shell-theorem-dependency-list-regexp) + (proof-dependency-in-span-context-menu span)))) + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Generic adjustmenth of prover's pretty-printing width +;; (adapted from Lego's mode, was also used in Isar and Plastic) +;; +;; FIXME: complete this. + +;(defvar pg-prover-current-line-width nil +; "Cache value for pg-adjust-line-width to avoid repeatedly changing width.") + +;(defun pg-adjust-line-width (buffer) +; "Adjust the prover's line width to match that of BUFFER." +; (proof-if-setting-configured proof-shell-adjust-line-width-cmd) +; proof-shell-(let* ((win (get-buffer-window buffer)) +; (curwid (if win (window-width win)))) +; (if (and curwid +; (not (equal curwid pg-prover-current-line-width))) +; (progn +; ;; Update the prover's output width +; (proof-shell-invisible-command + + +;with-current-buffer buffer +; (let ((current-width +; (window-width (get-buffer-window proof-goals-buffer))) +; (if (equal current-width lego-shell-current-line-width) () +; ; else +; (setq lego-shell-current-line-width current-width) +; (set-buffer proof-shell-buffer) +; (insert (format lego-pretty-set-width (- current-width 1))) +; ))))) + + + + +(provide 'pg-user) +;; pg-user.el ends here. diff --git a/generic/pg-xhtml.el b/generic/pg-xhtml.el new file mode 100644 index 00000000..c5f09ad9 --- /dev/null +++ b/generic/pg-xhtml.el @@ -0,0 +1,95 @@ +;; pg-xhtml.el XHTML goal display for Proof General +;; +;; Copyright (C) 2002 LFCS Edinburgh. +;; Author: David Aspinall <da@dcs.ed.ac.uk> +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; + +(require 'pg-xml) + +;; +;; Names for temporary files +;; +(defvar pg-xhtml-dir nil + "Default value for XHTML directory.") + +(defun pg-xhtml-dir () + "Temporary directory for storing XHTML files." + (or pg-xhtml-dir + (setq pg-xhtml-dir + (concat (if proof-running-on-win32 + "c:\\windows\\temp\\" ;; temp dir from env? + (or (concat (getenv "TMP") "/") "/tmp/")) + "pg" + (getenv "USER") + (int-to-string (emacs-pid)) + (char-to-string directory-sep-char))))) + +(defvar pg-xhtml-file-count 0 + "Counter for generating XHTML files.") + +(defun pg-xhtml-next-file () + "Return new file name for XHTML storage." + (concat + (pg-xhtml-dir) + (int-to-string (incf pg-xhtml-file-count)) + (if proof-running-on-win32 ".htm" ".html"))) + + +;; +;; Writing an XHMTL file +;; + +(defvar pg-xhtml-header + "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN +http://www.w3.org/TR/xhtml11/DTD/xhtml11-strict.dtd\">\n +<!-- This file was automatically generated by Proof General -->\n\n" + "Header for XHTML files.") + +(defmacro pg-xhtml-write-tempfile (&rest body) + "Write a new temporary XHTML file, returning its location. +BODY should contain a sequence of pg-xml writing commands." + (let ((dir (pg-xhtml-dir)) + (file (pg-xhtml-next-file))) + ;; + (or (eq (car-safe (file-attributes dir)) 't) + (if (not (file-attributes dir)) + (make-directory (pg-xhtml-dir) t) + (error "pg-xhtml-write-tempfile: cannot open temp dir " + (pg-xhtml-dir)))) + `(with-temp-file ,file + (pg-xml-begin-write t) + (pg-xml-add-text pg-xhtml-header) + ,@body + (insert (pg-xml-doc)) + ,file))) + +(defun pg-xhtml-cleanup-tempdir () + "Cleanup temporary directory used for XHTML files." + (delete-directory (pg-xhtml-dir))) + +(defvar pg-mozilla-prog-name + "/usr/bin/mozilla" + "Command name of browser to use with XHTML display.") + +(defun pg-xhtml-display-file-mozilla (file) + "Display FILENAME in netscape/mozilla." + (shell-command (concat pg-mozilla-prog-name + " -remote \"openURL(" file ")\""))) + +(defalias 'pg-xhtml-display-file 'pg-xhtml-display-file-mozilla) + +; Test doc +;(pg-xhtml-display-file-mozilla +;(pg-xhtml-write-tempfile +; (pg-xml-openelt 'root) +; (pg-xml-openelt 'a '((class . "1B"))) +; (pg-xml-writetext "text a") +; (pg-xml-closeelt) +; (pg-xml-closeelt))) + + +(provide 'pg-xhtml) +;; End of pg-xhtml diff --git a/generic/pg-xml.el b/generic/pg-xml.el new file mode 100644 index 00000000..7f0d48e1 --- /dev/null +++ b/generic/pg-xml.el @@ -0,0 +1,269 @@ +;; pg-xml.el XML functions for Proof General +;; +;; Copyright (C) 2000-2002 LFCS Edinburgh. +;; Author: David Aspinall <da@dcs.ed.ac.uk> +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; XML functions for Proof General +;; +;; STATUS: Experimental, not in use. +;; +;; Proof General Kit uses PGIP, an XML-message protocol +;; for interactive proof. The simple functions here allow +;; parsing and writing of XML documents. Little attempt +;; is made for efficiency, since PGIP documents are intended +;; to be small. No attempt at validation or handling +;; unicode characters is made. +;; + +;; TODO: +;; * Fix identifiers +;; * Fix whitespace handling +;; * Ignore prologues + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Parsing function: pg-xml-parse-buffer +;; + +(defconst pg-xml-name "[a-zA-Z_:][a-zA-Z0-9._:-]*") +(defconst pg-xml-space "[ \t\n
]") +(defconst pg-xml-ref (concat "&" pg-xml-name ";")) ; FIXME: charrefs + +(defconst pg-xml-start-open-elt-regexp + (concat pg-xml-space "*" "<\\(" pg-xml-name "\\)")) +(defconst pg-xml-end-open-elt-regexp + (concat pg-xml-space "*" "\\(/?\\)>")) +(defconst pg-xml-close-elt-regexp + (concat pg-xml-space "*" "</\\(" pg-xml-name "\\)>")) +(defconst pg-xml-attribute-regexp + (concat pg-xml-space "+" "\\(" pg-xml-name "\\)")) +(defconst pg-xml-attribute-val-regexp + (concat pg-xml-space "*" "=" pg-xml-space "*" + "\"\\(\\([^<&\"]\\|" pg-xml-ref "\\)*\\)\"")) ; FIXME or 's +(defconst pg-xml-comment-start-regexp "<!--") +(defconst pg-xml-comment-end-regexp "-->") +(defconst pg-xml-anymarkup-regexp "<") +(defconst pg-xml-special-elts + '(xml) + "List of special elements which don't require closing.") + +(defvar xmlparse nil + "Used to store parse result.") + +(defun pg-xml-add-text (text) + "If TEXT is non empty, add it to subtree at top of `xmlparse'." + (unless (string-equal text "") + (setq xmlparse (cons (cons text (car xmlparse)) + (cdr xmlparse))))) + + +(defun pg-xml-parse-buffer (&optional buffer nomsg) + "Parse an XML documment in BUFFER (defaulting to current buffer). +Return a lisp structure with symbols representing the element +names, so that the result of parsing + <elt attr=\"blah\">text</elt> +is + (elt ((attr . \"blah\")) (text))" + (unless nomsg + (message "Parsing %s..." (buffer-name buffer))) + (save-excursion + (if buffer (set-buffer buffer)) + (goto-char (point-min)) + (let ((xmlparse nil) + (pos (point)) + openelts elt) + (unless (looking-at pg-xml-start-open-elt-regexp) + (warn "pg-xml-parse-buffer: Junk at start of document: %s" + (buffer-substring + (point-min) + (min (save-excursion + (re-search-forward pg-xml-anymarkup-regexp nil t) + (match-beginning 0)) + (+ 10 (point-min)))))) + (while (re-search-forward pg-xml-anymarkup-regexp nil t) + (goto-char (match-beginning 0)) + (cond + ;; CASE 1: element opening + ((looking-at pg-xml-start-open-elt-regexp) + (setq elt (intern (match-string 1))) + ;; Add text before here to the parse, if non-empty + ;; FIXME: maybe unless last elt was opening too and + ;; only white space? + (pg-xml-add-text (buffer-substring pos (match-beginning 0))) + ;; Now look for any attributes + (goto-char (match-end 0)) + (let ((attrs nil) attr) + (while (looking-at pg-xml-attribute-regexp) + (setq attr (intern (match-string 1))) + (goto-char (match-end 0)) + (if (looking-at pg-xml-attribute-val-regexp) + (progn + (setq attr (cons attr (match-string 1))) + (goto-char (match-end 0)))) + (setq attrs (cons attr attrs))) + ;; Retain order in document + (setq attrs (reverse attrs)) + ;; Now we ought to be at the end of the element opening + (unless (looking-at pg-xml-end-open-elt-regexp) + (error "pg-xml-parse-buffer: Invalid XML in element opening %s" + (symbol-name elt))) + ;; Stack the element unless it's self closing + (if (> (length (match-string 1)) 0) + ;; Add element without nesting + (setq xmlparse (cons (cons (cons elt attrs) + (car xmlparse)) + (cdr xmlparse))) + ;; Otherwise stack and nest + (setq openelts (cons elt openelts)) + (setq xmlparse (cons (list (cons elt attrs)) + xmlparse)))) + (goto-char (match-end 0)) + (setq pos (point))) + + ;; CASE 2: element closing + ((looking-at pg-xml-close-elt-regexp) + (setq elt (intern (match-string 1))) + ;; It better be the top thing on the stack + (unless (eq elt (car-safe openelts)) + (error "pg-xml-parse-buffer: Invalid XML at element closing </%s> (expected </%s>)" + (symbol-name elt) + (if openelts + (symbol-name (car openelts)) + "no closing element"))) + ;; Add text before here to the parse + (pg-xml-add-text (buffer-substring pos (match-beginning 0))) + ;; Unstack the element and close subtree + (setq openelts (cdr openelts)) + (setq xmlparse (cons (cons + (reverse (car xmlparse)) + (cadr xmlparse)) + (cddr xmlparse))) + (goto-char (match-end 0)) + (setq pos (point))) + + ;; CASE 3: comment + ((looking-at pg-xml-comment-start-regexp) + (unless (re-search-forward pg-xml-comment-end-regexp nil t) + (error "pg-xml-parse-buffer: Unclosed comment beginning at line %s" + (1+ (count-lines (point-min) (point)))))))) + + ;; We'd better have nothing on the stack of open elements now. + (unless (null openelts) + (error "pg-xml-parse-buffer: Unexpected end of document, expected </%s>" + (symbol-name (car openelts)))) + ;; And we'd better be at the end of the document. + (unless (and (looking-at "[ \t\n]*") + (eq (match-end 0) (point-max))) + (warn "pg-xml-parse-buffer: Junk at end of document: %s" + (buffer-substring (point) + (min (point-max) (+ 30 (point-max)))))) + ;; Return the parse + ;; FIXME: + (unless nomsg + (message "Parsing %s...done" (buffer-name buffer))) + (caar xmlparse)))) + +;;;###autoload +(defun pg-xml-parse-string (arg) + "Parse string in ARG, same as pg-xml-parse-buffer." + (let + ((tempbuffer (get-buffer-create " *xml-parse*"))) + (save-excursion + (set-buffer tempbuffer) + (delete-region (point-min) (point-max)) + (insert-string arg) + (pg-xml-parse-buffer (current-buffer) 'nomessage)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Producing functions: state-based writing of an XML doc, +;; built up in pg-xml-doc +;; + +(defconst pg-xml-header + "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n") + +(defvar pg-xml-doc nil + "Current document being written (a reversed list of strings).") + +(defvar pg-xml-openelts nil + "Stack of openelements") + +(defvar pg-xml-indentp nil + "Whether to indent written XML documents") + +(defun pg-xml-encode-entities (string) + (progn + ;; rather inefficiently... + (setq string (replace-regexp-in-string (regexp-quote "<") "<" string)) + (setq string (replace-regexp-in-string (regexp-quote ">") "&rt;" string)) + (setq string (replace-regexp-in-string (regexp-quote "'") "'" string)) + (setq string (replace-regexp-in-string (regexp-quote "&") "&" string)) + (setq string (replace-regexp-in-string (regexp-quote "\"") """ string)) + string)) + +(defun pg-xml-begin-write (&optional header) + "Start writing an XML document. If HEADER is non-nil, add <?xml ?>" + (setq pg-xml-doc (if header (list pg-xml-header)) + pg-xml-openelts nil)) + +(defun pg-xml-indent () + (if pg-xml-indentp + (substring "\n " + 1 (length pg-xml-openelts)) + "")) + +(defun pg-xml-openelt (element &optional attributes) + (setq pg-xml-openelts (cons element pg-xml-openelts)) + (let (string) + (setq string (concat (pg-xml-indent) + "<" (symbol-name element))) + (while attributes + (if (consp (car attributes)) + (setq string (concat + string + " " + (symbol-name (caar attributes)) + "=" + (cdar attributes))) + (setq string (concat string + " " (symbol-name (car attributes))))) + (setq attributes (cdr attributes))) + (setq pg-xml-doc + (cons (concat string ">") pg-xml-doc)))) + +(defun pg-xml-closeelt () + (unless pg-xml-openelts + (error "pg-xml-closelt: no open elements")) + (setq pg-xml-doc + (cons + (concat + (pg-xml-indent) + "</" (symbol-name (car pg-xml-openelts)) ">") + pg-xml-doc)) + (setq pg-xml-openelts (cdr pg-xml-openelts))) + + +(defun pg-xml-writetext (text) + (setq pg-xml-doc (cons (concat (pg-xml-indent) text) pg-xml-doc))) + +(defun pg-xml-doc () + (apply 'concat (reverse pg-xml-doc))) + +;; Test document: +;;(progn +;; (pg-xml-begin-write t) +;; (pg-xml-openelt 'root) +;; (pg-xml-openelt 'a '((class . "1B"))) +;; (pg-xml-writetext "text a") +;; (pg-xml-closeelt) +;; (pg-xml-closeelt) +;; (pg-xml-doc)) + +(provide 'pg-xml) +;; End of `pg-xml.el' diff --git a/generic/proof-autoloads.el b/generic/proof-autoloads.el new file mode 100644 index 00000000..4a740e51 --- /dev/null +++ b/generic/proof-autoloads.el @@ -0,0 +1,230 @@ +;;; DO NOT MODIFY THIS FILE +(if (featurep 'proof-autoloads) (error "Already loaded")) + +;;;### (autoloads nil "_pkg" "generic/_pkg.el") + +(package-provide 'ProofGeneral :version "3.3pre010320" :type 'regular) + +;;;*** + +;;;### (autoloads (pg-pgip-askprefs pg-pgip-process-packet) "pg-pgip" "generic/pg-pgip.el") + +(autoload 'pg-pgip-process-packet "pg-pgip" "\ +Process the command packet PGIP, which is parsed XML according to pg-xml-parse-*" nil nil) + +(autoload 'pg-pgip-askprefs "pg-pgip" nil nil nil) + +;;;*** + +;;;### (autoloads (proof-next-error) "pg-response" "generic/pg-response.el") + +(autoload 'proof-next-error "pg-response" "\ +Jump to location of next error reported in the response buffer. + +A prefix arg specifies how many error messages to move; +negative means move back to previous error messages. +Just C-u as a prefix means reparse the error message buffer +and start at the first error." t nil) + +;;;*** + +;;;### (autoloads (pg-defthymode) "pg-thymodes" "generic/pg-thymodes.el") + +(autoload 'pg-defthymode "pg-thymodes" "\ +Define a Proof General mode for theory files. +Mode name is SYM-mode, named NAMED. BODY is the body of a setq and +can define a number of variables for the mode, viz: + + SYM-<font-lock-keywords> (value for font-lock-keywords) + SYM-<syntax-table-entries> (list of pairs: used for modify-syntax-entry calls) + SYM-<menu> (menu for the mode, arg of easy-menu-define) + SYM-<parent-mode> (defaults to fundamental-mode) + SYM-<filename-regexp> (regexp matching filenames for auto-mode-alist) + +All of these settings are optional." nil 'macro) + +;;;*** + +;;;### (autoloads (pg-xml-parse-string) "pg-xml" "generic/pg-xml.el") + +(autoload 'pg-xml-parse-string "pg-xml" "\ +Parse string in ARG, same as pg-xml-parse-buffer." nil nil) + +;;;*** + +;;;### (autoloads (proof-dependency-in-span-context-menu proof-depends-process-dependencies) "proof-depends" "generic/proof-depends.el") + +(autoload 'proof-depends-process-dependencies "proof-depends" "\ +Process dependencies reported by prover, for NAME in span GSPAN. +Called from `proof-done-advancing' when a save is processed and +proof-last-theorem-dependencies is set." nil nil) + +(autoload 'proof-dependency-in-span-context-menu "proof-depends" "\ +Make a portion of a context-sensitive menu showing proof dependencies." nil nil) + +;;;*** + +;;;### (autoloads (proof-easy-config) "proof-easy-config" "generic/proof-easy-config.el") + +(autoload 'proof-easy-config "proof-easy-config" "\ +Configure Proof General for proof-assistant using BODY as a setq body." nil 'macro) + +;;;*** + +;;;### (autoloads (proof-indent-line) "proof-indent" "generic/proof-indent.el") + +(autoload 'proof-indent-line "proof-indent" "\ +Indent current line of proof script, if indentation enabled." t nil) + +;;;*** + +;;;### (autoloads (defpacustom proof-defpacustom-fn proof-definvisible proof-defshortcut proof-menu-define-specific proof-menu-define-main proof-menu-define-keys) "proof-menu" "generic/proof-menu.el") + +(autoload 'proof-menu-define-keys "proof-menu" nil nil nil) + +(autoload 'proof-menu-define-main "proof-menu" nil nil nil) + +(autoload 'proof-menu-define-specific "proof-menu" nil nil nil) + +(autoload 'proof-defshortcut "proof-menu" "\ +Define shortcut function FN to insert STRING, optional keydef KEY. +This is intended for defining proof assistant specific functions. +STRING is inserted using `proof-insert', which see. +KEY is added onto proof-assistant map." nil 'macro) + +(autoload 'proof-definvisible "proof-menu" "\ +Define function FN to send STRING to proof assistant, optional keydef KEY. +This is intended for defining proof assistant specific functions. +STRING is sent using proof-shell-invisible-command, which see. +KEY is added onto proof-assistant map." nil 'macro) + +(autoload 'proof-defpacustom-fn "proof-menu" "\ +As for macro `defpacustom' but evaluating arguments." nil nil) + +(autoload 'defpacustom "proof-menu" "\ +Define a setting NAME for the current proof assitant, default VAL. +NAME can correspond to some internal setting, flag, etc, for the +proof assistant, in which case a :setting and :type value should be provided. +The :type of NAME should be one of 'integer, 'boolean, 'string. +The customization variable is automatically in group `proof-assistant-setting. +The function `proof-assistant-format' is used to format VAL. +If NAME corresponds instead to a PG internal setting, then a form :eval to +evaluate can be provided instead." nil 'macro) + +;;;*** + +;;;### (autoloads nil "proof-script" "generic/proof-script.el") + +;;;*** + +;;;### (autoloads (proof-shell-invisible-command proof-shell-wait proof-extend-queue proof-start-queue proof-shell-available-p proof-shell-live-buffer proof-shell-ready-prover) "proof-shell" "generic/proof-shell.el") + +(autoload 'proof-shell-ready-prover "proof-shell" "\ +Make sure the proof assistant is ready for a command. +If QUEUEMODE is set, succeed if the proof shell is busy but +has mode QUEUEMODE, which is a symbol or list of symbols. +Otherwise, if the shell is busy, give an error. +No change to current buffer or point." nil nil) + +(autoload 'proof-shell-live-buffer "proof-shell" "\ +Return buffer of active proof assistant, or nil if none running." nil nil) + +(autoload 'proof-shell-available-p "proof-shell" "\ +Returns non-nil if there is a proof shell active and available. +No error messages. Useful as menu or toolbar enabler." nil nil) + +(autoload 'proof-start-queue "proof-shell" "\ +Begin processing a queue of commands in ALIST. +If START is non-nil, START and END are buffer positions in the +active scripting buffer for the queue region. + +This function calls `proof-append-alist'." nil nil) + +(autoload 'proof-extend-queue "proof-shell" "\ +Extend the current queue with commands in ALIST, queue end END. +To make sense, the commands should correspond to processing actions +for processing a region from (buffer-queue-or-locked-end) to END. +The queue mode is set to 'advancing" nil nil) + +(autoload 'proof-shell-wait "proof-shell" "\ +Busy wait for `proof-shell-busy' to become nil, or for TIMEOUT seconds. +Needed between sequences of commands to maintain synchronization, +because Proof General does not allow for the action list to be extended +in some cases. May be called by `proof-shell-invisible-command'." nil nil) + +(autoload 'proof-shell-invisible-command "proof-shell" "\ +Send CMD to the proof process. +CMD may be a string or a string-yielding function. +Automatically add proof-terminal-char if necessary, examining +proof-shell-no-auto-terminate-commands. +By default, let the command be processed asynchronously. +But if optional WAIT command is non-nil, wait for processing to finish +before and after sending the command. +If WAIT is an integer, wait for that many seconds afterwards." nil nil) + +;;;*** + +;;;### (autoloads (proof-splash-message proof-splash-display-screen) "proof-splash" "generic/proof-splash.el") + +(autoload 'proof-splash-display-screen "proof-splash" "\ +Save window config and display Proof General splash screen. +If TIMEOUT is non-nil, time out outside this function, definitely +by end of configuring proof mode. +Otherwise, timeout inside this function after 10 seconds or so." t nil) + +(autoload 'proof-splash-message "proof-splash" "\ +Make sure the user gets welcomed one way or another." t nil) + +;;;*** + +;;;### (autoloads (proof-format) "proof-syntax" "generic/proof-syntax.el") + +(autoload 'proof-format "proof-syntax" "\ +Format a string by matching regexps in ALIST against STRING. +ALIST contains (REGEXP . REPLACEMENT) pairs where REPLACEMENT +may be a string or sexp evaluated to get a string." nil nil) + +;;;*** + +;;;### (autoloads (proof-toolbar-setup) "proof-toolbar" "generic/proof-toolbar.el") + +(autoload 'proof-toolbar-setup "proof-toolbar" "\ +Initialize Proof General toolbar and enable it for current buffer. +If proof-mode-use-toolbar is nil, change the current buffer toolbar +to the default toolbar." t nil) + +;;;*** + +;;;### (autoloads (proof-x-symbol-configure proof-x-symbol-shell-config proof-x-symbol-mode proof-x-symbol-decode-region proof-x-symbol-enable) "proof-x-symbol" "generic/proof-x-symbol.el") + +(autoload 'proof-x-symbol-enable "proof-x-symbol" "\ +Turn on or off support for x-symbol, initializing if necessary. +Calls proof-x-symbol-toggle-clean-buffers afterwards." nil nil) + +(autoload 'proof-x-symbol-decode-region "proof-x-symbol" "\ +Call (x-symbol-decode-region START END), if x-symbol support is enabled. +This converts tokens in the region into X-Symbol characters. +Return new END value." nil nil) + +(autoload 'proof-x-symbol-mode "proof-x-symbol" "\ +Turn on/off x-symbol mode in current buffer, from proof-x-symbol-enable. +The X-Symbol minor mode is only useful in buffers where symbol input +takes place (it isn't used for output-only buffers)." t nil) + +(autoload 'proof-x-symbol-shell-config "proof-x-symbol" "\ +Configure the proof shell for x-symbol, if proof-x-symbol-support<>nil. +Assumes that the current buffer is the proof shell buffer." nil nil) + +(autoload 'proof-x-symbol-configure "proof-x-symbol" "\ +Configure the current output buffer (goals/response/trace) for X-Symbol." nil nil) + +;;;*** + +;;;### (autoloads (texi-docstring-magic) "texi-docstring-magic" "generic/texi-docstring-magic.el") + +(autoload 'texi-docstring-magic "texi-docstring-magic" "\ +Update all texi docstring magic annotations in buffer." t nil) + +;;;*** + +(provide 'proof-autoloads) diff --git a/generic/proof-compat.el b/generic/proof-compat.el new file mode 100644 index 00000000..7a5fb8f4 --- /dev/null +++ b/generic/proof-compat.el @@ -0,0 +1,462 @@ +;; proof-compat.el Operating system and Emacs version compatibility +;; +;; Copyright (C) 2000-2002 LFCS Edinburgh. +;; Author: David Aspinall <da@dcs.ed.ac.uk> and others +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; This file collects together compatibility hacks for different +;; operating systems and Emacs versions. This is to help keep +;; track of them. +;; +;; The development policy for Proof General is for the main codebase +;; to be written for the latest stable version of XEmacs. We follow +;; XEmacs advice on removing obsolete function calls. +;; + +(require 'proof-site) ; for architecture flags + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Emacs and XEmacs modifications and adjustments +;;; + +;; Remove a custom setting. Needed to support dynamic reconfiguration. +;; (We'd prefer that repeated defcustom calls acted like repeated +;; "defvar treated as defconst" in XEmacs) +(defun pg-custom-undeclare-variable (symbol) + "Remove a custom setting SYMBOL. +Done by `makunbound' and removing all properties mentioned by custom library." + (mapcar (lambda (prop) (remprop symbol prop)) + '(default + standard-value + force-value + variable-comment + saved-variable-comment + variable-documentation + group-documentation + custom-set + custom-get + custom-options + custom-requests + custom-group + custom-prefix + custom-tag + custom-links + custom-version + saved-value + theme-value + theme-face)) + (makunbound symbol)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; XEmacs compatibility +;;; + +;; browse-url function isn't autoloaded in XEmacs 20.4 +(or (fboundp 'browse-url) + (autoload 'browse-url "browse-url" + "Ask a WWW browser to load URL." t)) + +;; executable-find isn't autoloaded in XEmacs 21.4.6 +(or (fboundp 'executable-find) + (autoload 'executable-find "executable" "\ +Search for COMMAND in exec-path and return the absolute file name. +Return nil if COMMAND is not found anywhere in `exec-path'." nil nil)) + + +;; Compatibility with XEmacs 20.3/4 +(or (boundp 'path-separator) + (setq path-separator (if proof-running-on-win32 ";" ":"))) +(or (fboundp 'split-path) + (defun split-path (path) + "Explode a search path into a list of strings. +The path components are separated with the characters specified +with `path-separator'." + (split-string path (regexp-quote path-separator)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; XEmacs compatibility with GNU Emacs +;;; + +(or (fboundp 'display-graphic-p) + (defun display-graphic-p () + "Return non-nil if DISPLAY is a graphic display. +Graphical displays are those which are capable of displaying several +frames and several different fonts at once. This is true for displays +that use a window system such as X, and false for text-only terminals." + (or (eq (console-type) 'x) + (eq (console-type) 'mswindows)))) + +(or (fboundp 'subst-char-in-string) +;; Code is taken from Emacs 21.2.1/subr.el +(defun subst-char-in-string (fromchar tochar string &optional inplace) + "Replace FROMCHAR with TOCHAR in STRING each time it occurs. +Unless optional argument INPLACE is non-nil, return a new string." + (let ((i (length string)) + (newstr (if inplace string (copy-sequence string)))) + (while (> i 0) + (setq i (1- i)) + (if (eq (aref newstr i) fromchar) + (aset newstr i tochar))) + newstr))) + +(or (fboundp 'replace-regexp-in-string) +;; Code is taken from Emacs 21.1.1/subr.el +(defun replace-regexp-in-string (regexp rep string &optional + fixedcase literal subexp start) + "Replace all matches for REGEXP with REP in STRING. + +Return a new string containing the replacements. + +Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the +arguments with the same names of function `replace-match'. If START +is non-nil, start replacements at that index in STRING. + +REP is either a string used as the NEWTEXT arg of `replace-match' or a +function. If it is a function it is applied to each match to generate +the replacement passed to `replace-match'; the match-data at this +point are such that match 0 is the function's argument. + +To replace only the first match (if any), make REGEXP match up to \\' +and replace a sub-expression, e.g. + (replace-regexp-in-string \"\\(foo\\).*\\'\" \"bar\" \" foo foo\" nil nil 1) + => \" bar foo\" +" + + ;; To avoid excessive consing from multiple matches in long strings, + ;; don't just call `replace-match' continually. Walk down the + ;; string looking for matches of REGEXP and building up a (reversed) + ;; list MATCHES. This comprises segments of STRING which weren't + ;; matched interspersed with replacements for segments that were. + ;; [For a `large' number of replacments it's more efficient to + ;; operate in a temporary buffer; we can't tell from the function's + ;; args whether to choose the buffer-based implementation, though it + ;; might be reasonable to do so for long enough STRING.] + (let ((l (length string)) + (start (or start 0)) + matches str mb me) + (save-match-data + (while (and (< start l) (string-match regexp string start)) + (setq mb (match-beginning 0) + me (match-end 0)) + ;; If we matched the empty string, make sure we advance by one char + (when (= me mb) (setq me (min l (1+ mb)))) + ;; Generate a replacement for the matched substring. + ;; Operate only on the substring to minimize string consing. + ;; Set up match data for the substring for replacement; + ;; presumably this is likely to be faster than munging the + ;; match data directly in Lisp. + (string-match regexp (setq str (substring string mb me))) + (setq matches + (cons (replace-match (if (stringp rep) + rep + (funcall rep (match-string 0 str))) + fixedcase literal str subexp) + (cons (substring string start mb) ; unmatched prefix + matches))) + (setq start me)) + ;; Reconstruct a string from the pieces. + (setq matches (cons (substring string start l) matches)) ; leftover + (apply #'concat (nreverse matches)))))) + + +;; The GNU Emacs implementation of easy-menu-define has a very handy +;; :visible keyword. To use that when it's available, we set a +;; constant to be :visible or :active + +(defconst menuvisiblep (if proof-running-on-Emacs21 :visible :active) + ":visible (on GNU Emacs) or :active (otherwise). +The GNU Emacs implementation of easy-menu-define has a very handy +:visible keyword. To use that when it's available, we use this constant.") + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; GNU Emacs compatibility +;;; + +;; Chars (borrowed from x-symbol-emacs.el compatability file) + +(unless (fboundp 'characterp) (defalias 'characterp 'integerp)) +(unless (fboundp 'int-to-char) (defalias 'int-to-char 'identity)) +(unless (fboundp 'char-to-int) (defalias 'char-to-int 'identity)) + +;; Missing function, but anyway Emacs has no datatype for events... + +(unless (fboundp 'events-to-keys) + (defalias 'events-to-keys 'identity)) + +(unless (fboundp 'region-exists-p) + (defun region-exists-p () mark-active)) + +;; completion not autoloaded in GNU 20.6.1; we must call +;; dynamic-completion-mode after loading it. +(or (fboundp 'complete) + (autoload 'complete "completion")) +(unless proof-running-on-XEmacs + (eval-after-load "completion" + '(dynamic-completion-mode))) + + +;; These days cl is dumped with XEmacs (20.4,21.1) but not GNU Emacs +;; 20.2. Would rather it was autoloaded but the autoloads are broken +;; in GNU so we load it now. +(require 'cl) + +;; Give a warning, +(or (fboundp 'warn) +(defun warn (str &rest args) + "Issue a warning STR. Defined by PG for GNU compatibility." + (apply 'message str args) + (sit-for 2))) + +;; Modeline redrawing (actually force-mode-line-update is alias on XEmacs) +(or (fboundp 'redraw-modeline) +(defun redraw-modeline (&rest args) + "Dummy function for Proof General on GNU Emacs." + (force-mode-line-update))) + +;; Interactive flag +(or (fboundp 'noninteractive) + (defun noninteractive () + "Dummy function for Proof General on GNU Emacs." + noninteractive)) + +;; Replacing in string (useful function from subr.el in XEmacs 21.1.9) +(or (fboundp 'replace-in-string) + (if (fboundp 'replace-regexp-in-string) + (defun replace-in-string (str regexp newtext &optional literal) + (replace-regexp-in-string regexp newtext str 'fixedcase literal)) +(defun replace-in-string (str regexp newtext &optional literal) + "Replace all matches in STR for REGEXP with NEWTEXT string, + and returns the new string. +Optional LITERAL non-nil means do a literal replacement. +Otherwise treat \\ in NEWTEXT string as special: + \\& means substitute original matched text, + \\N means substitute match for \(...\) number N, + \\\\ means insert one \\." + ;; Not present in GNU + ;; (check-argument-type 'stringp str) + ;; (check-argument-type 'stringp newtext) + (let ((rtn-str "") + (start 0) + (special) + match prev-start) + (while (setq match (string-match regexp str start)) + (setq prev-start start + start (match-end 0) + rtn-str + (concat + rtn-str + (substring str prev-start match) + (cond (literal newtext) + (t (mapconcat + (lambda (c) + (if special + (progn + (setq special nil) + (cond ((eq c ?\\) "\\") + ((eq c ?&) + (substring str + (match-beginning 0) + (match-end 0))) + ((and (>= c ?0) (<= c ?9)) + (if (> c (+ ?0 (length + (match-data)))) + ;; Invalid match num + (error "Invalid match num: %c" c) + (setq c (- c ?0)) + (substring str + (match-beginning c) + (match-end c)))) + (t (char-to-string c)))) + (if (eq c ?\\) (progn (setq special t) nil) + (char-to-string c)))) + newtext "")))))) + (concat rtn-str (substring str start)))))) + +;; An implemenation of buffer-syntactic-context for GNU Emacs +(defun proof-buffer-syntactic-context-emulate (&optional buffer) + "Return the syntactic context of BUFFER at point. +If BUFFER is nil or omitted, the current buffer is assumed. +The returned value is one of the following symbols: + + nil ; meaning no special interpretation + string ; meaning point is within a string + comment ; meaning point is within a line comment" + (save-excursion + (if buffer (set-buffer buffer)) + (let ((pp (parse-partial-sexp (point-min) (point)))) + (cond + ((nth 3 pp) 'string) + ;; ((nth 7 pp) 'block-comment) + ;; "Stefan Monnier" <monnier+misc/news@rum.cs.yale.edu> suggests + ;; distinguishing between block comments and ordinary comments + ;; is problematic: not what XEmacs claims and different to what + ;; (nth 7 pp) tells us in GNU Emacs. + ((nth 4 pp) 'comment))))) + + +;; In case Emacs is not aware of the function read-shell-command, +;; we duplicate some code adjusted from minibuf.el distributed +;; with XEmacs 21.1.9 +;; +;; This code is still required as of GNU Emacs 20.6.1 +;; +;; da: I think bothering with this just to give completion for +;; when proof-prog-name-ask=t is rather a big overkill! +;; Still, now it's here we'll leave it in as a pleasant surprise +;; for GNU Emacs users. +;; +(or (fboundp 'read-shell-command) +(defvar read-shell-command-map + (let ((map (make-sparse-keymap 'read-shell-command-map))) + (if (not (fboundp 'set-keymap-parents)) + (if (fboundp 'set-keymap-parent) + ;; GNU Emacs 20.2 + (set-keymap-parent map minibuffer-local-map) + ;; Earlier GNU Emacs + (setq map (append minibuffer-local-map map))) + ;; XEmacs versions without read-shell-command? + (set-keymap-parents map minibuffer-local-map)) + (define-key map "\t" 'comint-dynamic-complete) + (define-key map "\M-\t" 'comint-dynamic-complete) + (define-key map "\M-?" 'comint-dynamic-list-completions) + map) + "Minibuffer keymap used by `shell-command' and related commands.")) + + +(or (fboundp 'read-shell-command) +(defun read-shell-command (prompt &optional initial-input history) + "Just like read-string, but uses read-shell-command-map: +\\{read-shell-command-map}" + (let ((minibuffer-completion-table nil)) + (read-from-minibuffer prompt initial-input read-shell-command-map + nil (or history 'shell-command-history))))) + + +;; Emulate a useful builtin from XEmacs. + +(or (fboundp 'remassq) +(defun remassq (key alist) + "Delete any elements of ALIST whose car is `eq' to KEY. +The modified ALIST is returned." +;; The builtin version deletes by side-effect, but don't bother here. + (let (newalist) + (while alist + (unless (eq key (caar alist)) + (setq newalist (cons (car alist) newalist))) + (setq alist (cdr alist))) + (nreverse newalist)))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; A naughty hack to completion.el +;;; +;;; At the moment IMO completion too eagerly adds stuff to +;;; its database: the completion-before-command function +;;; makes every suffix be added as a completion! + +(eval-after-load "completion" +'(defun completion-before-command () + (if (and (symbolp this-command) (get this-command 'completion-function)) + (funcall (get this-command 'completion-function))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Old Emacs version compatibility +;;; + +;; Create a menu from a customize group, for older/non-existent customize + +(or (fboundp 'customize-menu-create) +(defun customize-menu-create (&rest args) + "Dummy function for PG; please upgrade your Emacs." + nil)) + +(or (fboundp 'process-live-p) +(defun process-live-p (obj) + "Return t if OBJECT is a process that is alive" + (and (processp obj) + (memq (process-status obj) '(open run stop))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; General Emacs version compatibility +;;; + + +;; These are internal functions of font-lock, autoload policy +;; differs between Emacs versions + +;; Beware: font-lock-set-defaults does completely different things +;; in Emacs from what it does in XEmacs. +(or (fboundp 'font-lock-set-defaults) + (autoload 'font-lock-set-defaults "font-lock")) +(or (fboundp 'font-lock-fontify-region) + (autoload 'font-lock-fontify-region "font-lock")) +(or (fboundp 'font-lock-append-text-property) + (autoload 'font-lock-append-text-property "font-lock")) + + +;; font-lock-preprocessor-face +;; This face is missing from Emacs 21.2's font-lock, +;; but used in Isabelle highlighting, at least. +(eval-after-load "font-lock" +(unless (boundp 'font-lock-preprocessor-face) + ;; Taken from font-lock.el in XEmacs 21.4.8 (V 1.52) + (defvar font-lock-preprocessor-face 'font-lock-preprocessor-face + "This variable should not be set. +The corresponding face should be set using `edit-faces' or the +`set-face-*' functions.") + + (defface font-lock-preprocessor-face + '((((class color) (background dark)) (:foreground "steelblue1")) + (((class color) (background light)) (:foreground "blue3")) + (t (:underline t))) + "Font Lock Mode face used to highlight preprocessor conditionals." + :group 'font-lock-faces))) + + +;; Handle buggy buffer-syntactic-context workaround in XEmacs 21.1, +;; and GNU non-implementation. + +(cond + ((not (fboundp 'buffer-syntactic-context)) + (defalias 'proof-buffer-syntactic-context + 'proof-buffer-syntactic-context-emulate)) + ((or + (string-match "21\.1 .*XEmacs" emacs-version) + (string-match "21\.4 .*XEmacs" emacs-version)) ;; still buggy in 21.4 + (defalias 'proof-buffer-syntactic-context + 'proof-buffer-syntactic-context-emulate)) + (t + ;; Rashly assume this version has a good implementation + (defalias 'proof-buffer-syntactic-context + 'buffer-syntactic-context))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Nasty: Emacs bug/problem fix section +;;; + + + + + +;; End of proof-compat.el +(provide 'proof-compat) diff --git a/generic/proof-config.el b/generic/proof-config.el new file mode 100644 index 00000000..777fd66c --- /dev/null +++ b/generic/proof-config.el @@ -0,0 +1,2478 @@ +;; proof-config.el Proof General configuration for proof assistant +;; +;; Copyright (C) 1998-2002 LFCS Edinburgh. +;; Author: David Aspinall <da@dcs.ed.ac.uk> and others +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; Maintainer: Proof General maintainer <proofgen@dcs.ed.ac.uk> +;; +;; $Id$ +;; +;; This file declares all user options and prover-specific +;; configuration variables for Proof General. The variables +;; are used variously by the proof script mode and the +;; proof shell mode, menus, and toolbar. +;; +;; To customize Proof General for a new proof assistant, you +;; should read this file carefully! +;; +;; 1. User options +;; 1b. Faces +;; +;; CONFIGURATION VARIABLES +;; 2. Major modes +;; 3. Menus, user-level commands, toolbar +;; 4. Script mode configuration +;; 5. Shell mode configuration +;; 5a. commands +;; 5b. regexps +;; 5c. hooks and others +;; 6. Goals buffer configuration +;; [ 7. Splash screen settings -- moved to proof-splash.el now ] +;; 8. X-Symbol support +;; 9. Prover specific settings +;; 10. Global constants +;; +;; The user options don't need to be set on a per-prover basis, +;; and the global constants probably should not be touched. +;; The remaining variables in sections 2-9 should be set for +;; each proof assistant. You don't need to set every variable +;; for basic functionality; consult the manual for details of +;; which ones are important. +;; +;; Customization groups and structure (sections in brackets) +;; +;; proof-general : Overall group +;; proof-user-options : User options for Proof General (1) +;; <ProverName> : User options for proof assistant (9) +;; <ProverName->-internals : Internal settings for proof assistant (9) +;; +;; proof-general-internals : Internal settings of Proof General +;; prover-config : Configuration for proof assistant (2,3) +;; proof-script : settings for proof script mode (4) +;; proof-shell : settings for proof shell mode (5) +;; proof-goals : settings for goals buffer (6) +;; proof-x-symbol : settings for X-Symbol (8) +;; <Prover name>-config : Specific internal settings for a prover +;; +;; ================================================== +;; +;; Developers notes: +;; i. When adding a new configuration variable, please +;; (a) put it in the right customize group, and +;; (b) add a magical comment in NewDoc.texi to document it! +;; ii. Presently the customize library seems a bit picky over the +;; :type property and some correct but complex types don't work +;; properly. +;; If the type is ill-formed, editing the whole group will be broken. +;; Check after updates, by killing all customize buffers and +;; invoking customize-group +;; +;; ================================================== + +(require 'proof-utils) ;; Macros used below + + +;; +;; 1. User options for proof mode +;; +;; The following variables are user options for Proof General. +;; They appear in the 'proof' customize group and should +;; *not* normally be touched by prover specific code. +;; + +(defgroup proof-user-options nil + "User options for Proof General." + :group 'proof-general + :prefix "proof-") + +(defcustom proof-electric-terminator-enable nil + "*If non-nil, use electric terminator mode. +If electric terminator mode is enabled, pressing a terminator will +automatically issue `proof-assert-next-command' for convenience, +to send the command straight to the proof process. If the command +you want to send already has a terminator character, you don't +need to delete the terminator character first. Just press the +terminator somewhere nearby. Electric!" + :type 'boolean + :set 'proof-set-value + :group 'proof-user-options) + +(defcustom proof-toolbar-enable t + "*If non-nil, display Proof General toolbar for script buffers. +NB: the toolbar is only available with XEmacs and GNU Emacs>=21." + :type 'boolean + :set 'proof-set-value + :group 'proof-user-options) + +(defpgcustom x-symbol-enable nil + "*Whether to use x-symbol in Proof General for this assistant. +If you activate this variable, whether or not you really get x-symbol +support depends on whether your proof assistant supports it and +whether X-Symbol is installed in your Emacs." + :type 'boolean + :set 'proof-set-value + :group 'proof-user-options) + +(defcustom proof-output-fontify-enable t + "*Whether to fontify output from the proof assistant. +If non-nil, output from the proof assistant will be highlighted +in the goals and response buffers. +\(This is providing font-lock-keywords have been set for the +buffer modes)." + :type 'boolean + :group 'proof-user-options) + +(defcustom proof-trace-output-fontify-enable t ;; testing + ;; (not (and proof-running-on-XEmacs (>= emacs-major-version 21))) production + "*Whether to fontify output from the proof assistant during tracing. +If non-nil and proof-output-fontify-enable is also non-nil, +output from the proof assistant will be highlighted in the trace buffer. +This is not recommended in XEmacs 21, since the font-lock parser +is easily overloaded by large tracing output." + :type 'boolean + :group 'proof-user-options) + +(defcustom proof-strict-state-preserving t + "*Whether Proof General is strict about the state preserving test. +Proof General lets the user send arbitrary commands to the proof +engine with `proof-minibuffer-cmd'. To attempt to preserve +synchronization, there may be a test `proof-state-preserving-p' +configured which prevents the user issuing certain commands +directly (instead, they may only be entered as part of the script). + +Clever or arrogant users may want to avoid this test, which is +done if this `proof-strict-state-preserving' is turned off (nil)." + :type 'boolean + :group 'proof-user-options) + +(defcustom proof-strict-read-only 'strict + "*Whether Proof General is strict about the read-only region in buffers. +If non-nil, an error is given when an attempt is made to edit the +read-only region. If nil, Proof General is more relaxed (but may give +you a reprimand!). + +If you change proof-strict-read-only during a session, you must +use the \"Restart\" button (or \\[proof-shell-restart]) before +you can see the effect in buffers. + +The default value for proof-strict-read-only depends on which +version of Emacs you are using. In GNU Emacs, strict read only is buggy +when it used in conjunction with font-lock, so it is disabled by default." + :type 'boolean + :group 'proof-user-options) + + +(defcustom proof-three-window-mode nil + "*Whether response and goals buffers have dedicated windows. +If non-nil, Emacs windows displaying messages from the prover will not +be switchable to display other windows. + +This option can help manage your display. + +Setting this option triggers a three-buffer mode of interaction where +the goals buffer and response buffer are both displayed, rather than +the two-buffer mode where they are switched between. It also prevents +Emacs automatically resizing windows between proof steps. + +If you use several frames (the same Emacs in several windows on the +screen), you can force a frame to stick to showing the goals or +response buffer. + +For single frame use this option may be inconvenient for +experienced Emacs users." + :type 'boolean + :group 'proof-user-options) + +(defcustom proof-multiple-frames-enable nil + "*Whether response and goals buffers have separate frames. +If non-nil, Emacs will make separate frames (screen windows) for +the goals and response buffers, by altering the Emacs variable +`special-display-regexps'." + :type 'boolean + :set 'proof-set-value + :group 'proof-user-options) + +(defcustom proof-delete-empty-windows nil + "*If non-nil, automatically remove windows when they are cleaned. +For example, at the end of a proof the goals buffer window will +be cleared; if this flag is set it will automatically be removed. +If you want to fix the sizes of your windows you may want to set this +variable to 'nil' to avoid windows being deleted automatically. +If you use multiple frames, only the windows in the currently +selected frame will be automatically deleted." + :type 'boolean + :group 'proof-user-options) + +(defcustom proof-shrink-windows-tofit nil + "*If non-nil, automatically shrink output windows to fit contents. +In single-frame mode, this option will reduce the size of the +goals and response windows to fit their contents." + :type 'boolean + :group 'proof-user-options) + +(defcustom proof-toolbar-use-button-enablers + (not + (or + ;; Disabled by default for win32 and solaris + proof-running-on-win32 + (and (boundp 'system-configuration) + (string-match "sun-solaris" system-configuration)))) + "*If non-nil, toolbars buttons may be enabled/disabled automatically. +Toolbar buttons can be automatically enabled/disabled according to +the context. Set this variable to nil if you don't like this feature +or if you find it unreliable. + +Notes: +* Toolbar enablers are only available with XEmacs 21 and later. +* With this variable nil, buttons do nothing when they would +otherwise be disabled. +* If you change this variable it will only be noticed when you +next start Proof General. +* The default value for XEmacs built for solaris is nil, because +of unreliabilities with enablers there." + :type 'boolean + :group 'proof-user-options) + +; (defcustom proof-auto-retract +; nil +; "*If non-nil, retract automatically when locked region is edited. +; With this option active, the locked region will automatically be +; unlocked when the user attempts to edit it. To make use of this +; option, proof-strict-read-only should be turned off. + +; Note: this feature has not been implemented yet, it is only an idea." +; :type 'boolean +; :group 'proof-user-options) + +(defcustom proof-query-file-save-when-activating-scripting + t +"*If non-nil, query user to save files when activating scripting. + +Often, activating scripting or executing the first scripting command +of a proof script will cause the proof assistant to load some files +needed by the current proof script. If this option is non-nil, the +user will be prompted to save some unsaved buffers in case any of +them corresponds to a file which may be loaded by the proof assistant. + +You can turn this option off if the save queries are annoying, but +be warned that with some proof assistants this may risk processing +files which are out of date with respect to the loaded buffers!" + :type 'boolean + :group 'proof-user-options) + +(defpgcustom script-indent t + "*If non-nil, enable indentation code for proof scripts." + :type 'boolean + :group 'proof-user-options) + +;; FIXME: implement it! Use in indentation code. +(defcustom proof-one-command-per-line + nil + "*If non-nil, format for newlines after each proof command in a script. +This option is not fully-functional at the moment." + :type 'boolean + :group 'proof-user-options) + + +(defcustom proof-prog-name-ask + nil + "*If non-nil, query user which program to run for the inferior process." + :type 'boolean + :group 'proof-user-options) + +(defcustom proof-prog-name-guess + nil + "*If non-nil, use `proof-guess-command-line' to guess proof-prog-name. +This option is compatible with proof-prog-name-ask. +No effect if proof-guess-command-line is nil." + :type 'boolean + :group 'proof-user-options) + +(defcustom proof-tidy-response + t + "*Non-nil indicates that the response buffer should be cleared often. +The response buffer can be set either to accumulate output, or to +clear frequently. + +With this variable non-nil, the response buffer is kept tidy by +clearing it often, typically between successive commands (just like the +goals buffer). + +Otherwise the response buffer will accumulate output from the prover." + :type 'boolean + :group 'proof-user-options) + +(defcustom proof-show-debug-messages nil + "*Whether to display debugging messages in the response buffer. +If non-nil, debugging messages are displayed in the response giving +information about what Proof General is doing. +To avoid erasing the messages shortly after they're printed, +you should set `proof-tidy-response' to nil." + :type 'boolean + :group 'proof-user-options) + +(defcustom proof-experimental-features + ;; Turn on experimental features for pre-releases. + (if (string-match "pre" proof-general-version) t) + "*Whether to enable certain features regarded as experimental. +Proof General includes a few features designated as \"experimental\". +Enabling these will usually have no detrimental effects on using PG, +but the features themselves may be buggy. + +We encourage users to set this flag and test the features, but being +aware that the features may be buggy (problem reports and +suggestions for improvements are welcomed). + +By default, experimental features are turned on in development +releases and turned off in stable releases." + :type 'boolean + :group 'proof-user-options) + +;;; NON BOOLEAN OPTIONS + +(defcustom proof-follow-mode 'locked + "*Choice of how point moves with script processing commands. +One of the symbols: 'locked, 'follow, 'ignore. + +If 'locked, point sticks to the end of the locked region. +If 'follow, point moves just when needed to display the locked region end. +If 'ignore, point is never moved after movement commands or on errors. + +If you choose 'ignore, you can find the end of the locked using +`M-x proof-goto-end-of-locked'." + :type '(choice + (const :tag "Follow locked region" locked) + (const :tag "Keep locked region displayed" follow) + (const :tag "Never move" ignore)) + :group 'proof-user-options) + +(defcustom proof-auto-action-when-deactivating-scripting nil + "*If 'retract or 'process, do that when deactivating scripting. + +With this option set to 'retract or 'process, when scripting +is turned off in a partly processed buffer, the buffer will be +retracted or processed automatically. + +With this option unset (nil), the user is questioned instead. + +Proof General insists that only one script buffer can be partly +processed: all others have to be completely processed or completely +unprocessed. This is to make sure that handling of multiple files +makes sense within the proof assistant. + +NB: A buffer is completely processed when all non-whitespace is +locked (coloured blue); a buffer is completely unprocessed when there +is no locked region." + :type '(choice + (const :tag "No automatic action; query user" nil) + (const :tag "Automatically retract" retract) + (const :tag "Automatically process" process)) + :group 'proof-user-options) + +(defcustom proof-script-command-separator " " + "*String separating commands in proof scripts. +For example, if a proof assistant prefers one command per line, then +this string should be set to a newline. Otherwise it should be +set to a space." + :type 'string + :group 'proof-user-options) + +(defcustom proof-rsh-command "" + "*Shell command prefix to run a command on a remote host. +For example, + + ssh bigjobs + +Would cause Proof General to issue the command `ssh bigjobs isabelle' +to start Isabelle remotely on our large compute server called `bigjobs'. + +The protocol used should be configured so that no user interaction +(passwords, or whatever) is required to get going. For proper +behaviour with interrupts, the program should also communicate +signals to the remote host." + :type 'string + :group 'proof-user-options) + +(defcustom proof-disappearing-proofs nil + "*Non-nil causes Proof General to hide proofs as they are completed." + :type 'boolean + :group 'proof-user-options) + + + + + +;; +;; 1b. Faces. +;; +;; We should test that settings work sensibly: +;; a) with default colours +;; b) with -rv +;; c) on console +;; d) on win32 +;; e) all above with GNU Emacs and XEmacs. +;; But it's difficult to keep track of all that! +;; Please report any bad/failing colour +;; combinations to proofgen@dcs.ed.ac.uk +;; +;; Some of these faces aren't used by default in Proof General, +;; but you can use them in font lock patterns for specific +;; script languages. +;; + +(defgroup proof-faces nil + "Faces used by Proof General." + :group 'proof-general + :prefix "proof-") + +(defmacro proof-face-specs (bl bd ow) + "Return a spec for `defface' with BL for light bg, BD for dark, OW o/w." + `(append + (apply 'append + (mapcar + (lambda (ty) (list + (list (list (list 'type ty) '(class color) + (list 'background 'light)) + (quote ,bl)) + (list (list (list 'type ty) '(class color) + (list 'background 'dark)) + (quote ,bd)))) + '(x mswindows gtk))) + (list (list t (quote ,ow))))) + +(defface proof-queue-face + (proof-face-specs + (:background "darksalmon") ;; was "mistyrose" in 3.3 + (:background "mediumvioletred") + (:foreground "white" :background "black")) + "*Face for commands in proof script waiting to be processed." + :group 'proof-faces) + +(defface proof-locked-face + (proof-face-specs + (:background "lightsteelblue") ;; was "lavender", later "lightcyan" in 3.3 + (:background "navy") + (:underline t)) + "*Face for locked region of proof script (processed commands)." + :group 'proof-faces) + +(defface proof-declaration-name-face + (proof-face-specs + (:foreground "chocolate" :bold t) + (:foreground "orange" :bold t) + (:italic t :bold t)) + "*Face for declaration names in proof scripts. +Exactly what uses this face depends on the proof assistant." + :group 'proof-faces) + +;; FIXME da: are these defconsts still needed now we use defface? +;; Answer: yes, for GNU Emacs they are. + +(defconst proof-declaration-name-face 'proof-declaration-name-face + "Expression that evaluates to a face. +Required so that 'proof-declaration-name-face is a proper facename in +both XEmacs 20.4 and Emacs 20.2's version of font-lock.") + +(defface proof-tacticals-name-face + (proof-face-specs + (:foreground "MediumOrchid3") + (:foreground "orchid") + (bold t)) + "*Face for names of tacticals in proof scripts. +Exactly what uses this face depends on the proof assistant." + :group 'proof-faces) + +(defconst proof-tacticals-name-face 'proof-tacticals-name-face + "Expression that evaluates to a face. +Required so that 'proof-tacticals-name-face is a proper facename in +both XEmacs 20.4 and Emacs 20.3's version of font-lock.") + +(defface proof-tactics-name-face + (proof-face-specs + (:foreground "darkblue") + (:foreground "mediumpurple") + (:underline t)) + "*Face for names of tactics in proof scripts. +Exactly what uses this face depends on the proof assistant." + :group 'proof-faces) + +(defconst proof-tactics-name-face 'proof-tactics-name-face + "Expression that evaluates to a face. +Required so that 'proof-tactics-name-face is a proper facename in +both XEmacs 20.4 and Emacs 20.3's version of font-lock.") + +(defface proof-error-face + (proof-face-specs + (:background "salmon1" :bold t) + (:background "brown" :bold t) + (:bold t)) + "*Face for error messages from proof assistant." + :group 'proof-faces) + +(defface proof-warning-face + (proof-face-specs + (:background "lemon chiffon") + (:background "orange2") + (:italic t)) + "*Face for warning messages. +Warning messages can come from proof assistant or from Proof General itself." + :group 'proof-faces) + +(defface proof-eager-annotation-face + (proof-face-specs + (:background "palegoldenrod") + (:background "darkgoldenrod") + (:italic t)) + "*Face for important messages from proof assistant." + :group 'proof-faces) + +(defface proof-debug-message-face + (proof-face-specs + (:foreground "Gray65") + (:background "Gray30") + (:italic t)) + "*Face for debugging messages from Proof General." + :group 'proof-faces) + +(defface proof-boring-face + (proof-face-specs + (:foreground "Gray65") + (:background "Gray30") + (:italic t)) + "*Face for boring text in proof assistant output." + :group 'proof-faces) + +(defface proof-mouse-highlight-face + (proof-face-specs + (:background "lightblue") + (:background "darkslateblue") + (:italic t)) + "*General mouse highlighting face." + :group 'proof-faces) + +(defface proof-highlight-dependent-face + (proof-face-specs + (:background "orange") + (:background "darkorange") + (:italic t)) + "*Face for showing (backwards) dependent parts." + :group 'proof-faces) + +(defface proof-highlight-dependency-face + (proof-face-specs + (:background "khaki") + (:background "peru") + (:italic t)) + "*Face for showing (forwards) dependencies." + :group 'proof-faces) + + + + + +;; +;; START OF CONFIGURATION VARIABLES +;; +;; Prelude +;; + +(defgroup prover-config nil + "Configuration of Proof General for the prover in use." + :group 'proof-general-internals + :prefix "proof-") + +;; The variables in the "prover-config" (NB: not "proof config"!!) +;; customize group are those which are intended to be set by the +;; prover specific elisp, i.e. constants set on a per-prover basis. + +;; Putting these in a customize group is useful for documenting +;; this type of variable, and for developing a new instantiation +;; of Proof General. +;; But it is *not* useful for final user-level customization! +;; The reason is that saving these customizations across a session is +;; not liable to work, because the prover specific elisp usually +;; overrides with a series of setq's in <assistant>-mode-config type +;; functions. This is why prover-config appears under the +;; proof-general-internal group. + + + + + + + + +;; +;; 2. Major modes used by Proof General. +;; +;; The first three settings are used when starting a shell, +;; so the must be set before a shell is started, so we +;; know what modes are needed for each of the buffers. +;; Hence the use of pre-shell-start-hook. + +(defcustom proof-mode-for-shell 'proof-shell-mode + "Mode for proof shell buffers. +Usually customised for specific prover. +Suggestion: this can be set a function called by `proof-pre-shell-start-hook'." + :type 'function + :group 'prover-config) + +(defcustom proof-mode-for-response 'proof-response-mode + "Mode for proof response buffer (and trace buffer, if used). +Usually customised for specific prover. +Suggestion: this can be set a function called by `proof-pre-shell-start-hook'." + :type 'function + :group 'prover-config) + +(defcustom proof-mode-for-goals 'proof-goals-mode + "Mode for proof state display buffers. +Usually customised for specific prover. +Suggestion: this can be set a function called by `proof-pre-shell-start-hook'." + :type 'function + :group 'prover-config) + +(defcustom proof-mode-for-script 'proof-mode + "Mode for proof script buffers. +This is used by Proof General to find out which buffers +contain proof scripts. +The regular name for this is <PA>-mode. If you use any of the +convenience macros Proof General provides for defining commands +etc, then you should stick to this name. +Suggestion: this can be set in the script mode configuration." + :type 'function + :group 'prover-config) + +(defcustom proof-guess-command-line nil + "Function to guess command line for proof assistant, given a filename. +The function could take a filename as argument, run `make -n' to see +how to compile the file non-interactively, then translate the result +into an interactive invocation of the proof assistant with the same +command line options. For an example, see coq/coq.el." + :type 'function + :group 'prover-config) + + + +;; +;; 3. Configuration for menus, user-level commands, toolbar, etc. +;; + +(defcustom proof-assistant-home-page "" + "Web address for information on proof assistant. +Used for Proof General's help menu." + :type 'string + :group 'prover-config) + +(defcustom proof-context-command nil + "Command to display the context in proof assistant." + :type 'string + :group 'prover-config) + +(defcustom proof-info-command nil + "Command to ask for help or information in the proof assistant. +String or fn. If a string, the command to use. +If a function, it should return the command string to insert." + :type '(choice string function) + :group 'prover-config) + +(defcustom proof-showproof-command nil + "Command to display proof state in proof assistant." + :type 'string + :group 'prover-config) + +(defcustom proof-goal-command nil + "Command to set a goal in the proof assistant. String or fn. +If a string, the format character `%s' will be replaced by the +goal string. +If a function, it should return the command string to insert." + :type '(choice string function) + :group 'prover-config) + +(defcustom proof-save-command nil + "Command to save a proved theorem in the proof assistant. String or fn. +If a string, the format character `%s' will be replaced by the +theorem name. +If a function, it should return the command string to insert." + :type '(choice string function) + :group 'prover-config) + +(defcustom proof-find-theorems-command nil + "Command to search for a theorem containing a given term. String or fn. +If a string, the format character `%s' will be replaced by the term. +If a function, it should return the command string to insert." + :type '(choice string function) + :group 'prover-config) + +(defconst proof-toolbar-entries-default + `((state "Display Proof State" "Display the current proof state" t + proof-showproof-command) + (context "Display Context" "Display the current context" t + proof-context-command) + (goal "Start a New Proof" "Start a new proof" t + proof-goal-command) + (retract "Retract Buffer" "Retract (undo) whole buffer" t) + (undo "Undo Step" "Undo the previous proof command" t) + (delete "Delete Step" nil t) + (next "Next Step" "Process the next proof command" t) + (use "Use Buffer" "Process whole buffer" t) + (goto "Goto Point" "Process or undo to the cursor position" t) + (restart "Restart Scripting" "Restart scripting (clear all locked regions)" t) + (qed "Finish Proof" "Close/save proved theorem" t + proof-save-command) + (lockedend "Goto Locked End" nil t) + (find "Find Theorems" "Find theorems" t proof-find-theorems-command) + (command "Issue Command" "Issue a non-scripting command" t) + (interrupt "Interrupt Prover" "Interrupt the proof assistant (warning: may break synchronization)" t) + (visibility "Toggle Visibility" nil t) + (info nil "Show online proof assistant information" t + proof-info-command) + (help nil "Proof General manual" t)) +"Example value for proof-toolbar-entries. Also used to define scripting menu. +This gives a bare toolbar that works for any prover, providing the +appropriate configuration variables are set. +To add/remove prover specific buttons, adjust the `<PA>-toolbar-entries' +variable, and follow the pattern in `proof-toolbar.el' for +defining functions, images.") + +(defpgcustom toolbar-entries proof-toolbar-entries-default + "List of entries for Proof General toolbar and Scripting menu. +Format of each entry is (TOKEN MENUNAME TOOLTIP DYNAMIC-ENABLER-P ENABLE). + +For each TOKEN, we expect an icon with base filename TOKEN, +a function proof-toolbar-<TOKEN>, and (optionally) a dynamic enabler +proof-toolbar-<TOKEN>-enable-p. + +If ENABLEP is absent, item is enabled; if ENABLEP is present, item +is only added to menubar and toolbar if ENABLEP is non-null. + +If MENUNAME is nil, item will not appear on the scripting menu. + +If TOOLTIP is nil, item will not appear on the toolbar. + +The default value is `proof-toolbar-entries-default' which contains +the standard Proof General buttons.") + +(defcustom proof-assistant-true-value "true" + "String for true values in proof assistant, used for setting flags. +Default is the string \"true\"." + :type 'string + :group 'prover-config) + +(defcustom proof-assistant-false-value "false" + "String for false values in proof assistant, used for setting flags. +Default is the string \"false\"." + :type 'string + :group 'prover-config) + +(defcustom proof-assistant-format-int-fn 'int-to-string + "Function for converting integer values to ints in proof assistant. +Used for configuring settings in proof assistant. +Default is `int-to-string'." + :type 'function + :group 'prover-config) + +(defcustom proof-assistant-format-string-fn (lambda (value) value) + "Function for converting string values to strings in proof assistant. +Used for configuring settings in proof assistant. +Default is the identity function." + :type 'string + :group 'prover-config) + +(defcustom proof-assistant-setting-format nil + "Function for formatting setting strings for proof assistant. +Setting strings are calculated by replacing a format character +%b, %i, or %s in the :setting string in for each variable defined with +`defpacustom', using the current value of that variable. This +function is applied as a final step to do any extra markup, or +conversion, etc. (No changes are done if nil)." + :type '(choice string nil) + :group 'prover-config) + + + +;; +;; 4. Configuration for proof script mode +;; + +;; +;; The following variables should be set before proof-config-done +;; is called. These configure the mode for the script buffer, +;; including highlighting, etc. +;; + +(defgroup proof-script nil + "Proof General configuration of scripting buffer mode." + :group 'prover-config + :prefix "proof-") + +(defcustom proof-terminal-char nil + "Character which terminates every command sent to proof assistant. nil if none. + +To configure command recognition properly, you must set at least one +of these: `proof-script-sexp-commands', `proof-script-command-end-regexp', +`proof-script-command-start-regexp', `proof-terminal-char', +or `proof-script-parse-function'." + :type 'character + :group 'prover-config) + +(defcustom proof-script-sexp-commands nil + "Non-nil if proof script has a LISP-like syntax, and commands are top-level sexps. +You should set this variable in script mode configuration. + +To configure command recognition properly, you must set at least one +of these: `proof-script-sexp-commands', `proof-script-command-end-regexp', +`proof-script-command-start-regexp', `proof-terminal-char', +or `proof-script-parse-function'." + :type 'boolean + :group 'prover-config) + +(defcustom proof-script-command-end-regexp nil + "Regular expression which matches end of commands in proof script. +You should set this variable in script mode configuration. + +To configure command recognition properly, you must set at least one +of these: `proof-script-sexp-commands', `proof-script-command-end-regexp', +`proof-script-command-start-regexp', `proof-terminal-char', +or `proof-script-parse-function'." + :type 'string + :group 'prover-config) + +(defcustom proof-script-command-start-regexp nil + "Regular expression which matches start of commands in proof script. +You should set this variable in script mode configuration. + +To configure command recognition properly, you must set at least one +of these: `proof-script-sexp-commands', `proof-script-command-end-regexp', +`proof-script-command-start-regexp', `proof-terminal-char', +or `proof-script-parse-function'." + :type 'string + :group 'prover-config) + +(defcustom proof-script-use-old-parser nil ;;experiment and let folk complain + "Whether to use the old parsing mechanism. +By default, this is set to nil in Proof General 3.5. +Please report any proof script parsing oddities to +support@proofgeneral.org. + +(NB: Specific example where new parser fails: Isar relies on certain +text being sent to prover which according to syntax configuration +are comments; new parser does not send these currently.)" + :type 'boolean + :group 'prover-config) + +(defcustom proof-script-integral-proofs nil + "Whether the complete text after a goal confines the actual proof. + +In structured proof languages like Isabelle/Isar a theorem is +established by a goal statement (with full information about the +result, including name and statement), followed by a self-contained +piece of text for the proof. The latter should be treated as an +integral entity for purposes of hiding proof bodies etc. + +This variable is better set to nil for tactical provers (like Coq) +where important information about the result is spread over the +initial ``goal'' and the final ``save'' command." + :type 'boolean + :group 'prover-config) + +(defcustom proof-script-fly-past-comments nil + "*If non-nil, fly past comments when scripting, coalescing them into single spans. +The default setting for this before PG 3.5 was t, now it is nil. If you +prefered the old behaviour, customize this variable to t." + :type 'boolean + :group 'prover-config) + +(defcustom proof-script-parse-function nil + "A function which parses a portion of the proof script. +It is called with the proof script as the current buffer, and +point the position where the parse should begin. It should +move point to the exact end of the next \"segment\", and return +a symbol indicating what has been parsed: + + 'comment for a comment + 'cmd for a proof script command + nil if there is no complete next segment in the buffer + +If this is left unset, it will be configured automatically to +a generic function according to which of `proof-terminal-char' +and its friends are set." + :type 'string + :group 'prover-config) + + +(defcustom proof-script-comment-start "" + "String which starts a comment in the proof assistant command language. +The script buffer's comment-start is set to this string plus a space. +Moreover, comments are usually ignored during script management, and not +sent to the proof process. + +You should set this variable for reliable working of Proof General, +as well as `proof-script-comment-end'." + :type 'string + :group 'proof-script) + +(defcustom proof-script-comment-start-regexp nil + "Regexp which matches a comment start in the proof command language. + +The default value for this is set as (regexp-quote proof-script-comment-start) +but you can set this variable to something else more precise if necessary." + :type 'string + :group 'proof-script) + +(defcustom proof-script-comment-end "\n" + "String which ends a comment in the proof assistant command language. +The script buffer's comment-end is set to a space plus this string. +See also `proof-script-comment-start'. + +You should set this variable for reliable working of Proof General," + :type 'string + :group 'proof-script) + +(defcustom proof-script-comment-end-regexp nil + "Regexp which matches a comment end in the proof command language. + +The default value for this is set as (regexp-quote proof-script-comment-end) +but you can set this variable to something else more precise if necessary." + :type 'string + :group 'proof-script) + +(defcustom pg-insert-output-as-comment-fn nil + "Function to insert last output as a comment. Passed output as arg. +If left as nil, the default behaviour is to insert and call `comment-region'." + :type '(choice function nil) + :group 'proof-script) + +(defcustom proof-string-start-regexp "\"" + "Matches the start of a quoted string in the proof assistant command language." + :type 'string + :group 'proof-script) + +(defcustom proof-string-end-regexp "\"" + "Matches the end of a quoted string in the proof assistant command language." + :type 'string + :group 'proof-script) + +(defcustom proof-case-fold-search nil + "Value for case-fold-search when recognizing portions of proof scripts. +Also used for completion, via `proof-script-complete'. +The default value is `nil'. If your prover has a case *insensitive* +input syntax, proof-case-fold-search should be set to `t' instead. +NB: This setting is not used for matching output from the prover." + :type 'boolean :group + 'proof-script) + +(defcustom proof-save-command-regexp nil + "Matches a save command." + :type 'regexp + :group 'proof-script) + +(defcustom proof-save-with-hole-regexp nil + "Regexp which matches a command to save a named theorem. +The name of the theorem is build from the variable +proof-save-with-hole-result using the same convention as +query-replace-regexp. +Used for setting names of goal..save and proof regions and for +default function-menu configuration in proof-script-find-next-entity. + +It's safe to leave this setting as nil." + :type 'regexp + :group 'proof-script) + +(defcustom proof-save-with-hole-result 2 + "String or Int: how to build the theorem name after matching +with proof-save-with-hole-regexp. If it is an int N use match-string +to recover the value of the Nth parenthesis matched. If it is a string +use replace-match. It the later case, proof-save-with-hole-regexp should +match the entire command" + + :type '(choice string int) + :group 'proof-script) + +;; FIXME: unify uses so that proof-anchor-regexp works sensibly +(defcustom proof-goal-command-regexp nil + "Matches a goal command in the proof script. +This is used (1) to make the default value for `proof-goal-command-p', +used as an important part of script management to find the start +of an atomic undo block, and (2) to construct the default +for `proof-script-next-entity-regexps' used for function menus." + :type 'regexp + :group 'proof-script) + +(defcustom proof-goal-with-hole-regexp nil + "Regexp which matches a command used to issue and name a goal. +The name of the theorem is build from the variable +proof-goal-with-hole-result using the same convention as +query-replace-regexp. +Used for setting names of goal..save regions and for default +function-menu configuration in proof-script-find-next-entity. + +It's safe to leave this setting as nil." + :type 'regexp + :group 'proof-script) + +(defcustom proof-goal-with-hole-result 2 + "String or Int: how to build the theorem name after matching +with proof-goal-with-hole-regexp. If it is an int N use match-string +to recover the value of the Nth parenthesis matched. If it is a string +use replace-match. It the later case, proof-goal-with-hole-regexp should +match the entire command" + + :type '(choice string int) + :group 'proof-script) + +(defcustom proof-non-undoables-regexp nil + "Regular expression matching commands which are *not* undoable. +These are commands which should not appear in proof scripts, +for example, undo commands themselves (if the proof assistant +cannot \"redo\" an \"undo\"). +Used in default functions `proof-generic-state-preserving-p' +and `proof-generic-count-undos'. If you don't use those, +may be left as nil." + :type '(choice nil regexp) + :group 'proof-script) + +(defcustom proof-nested-undo-regexp nil + "Regexp for commands that must be counted in nested goal-save regions. + +Used for provers which allow nested atomic goal-saves, but with some +nested history that must be undone specially. + +At the moment, the behaviour is that a goal-save span has a 'nestedundos +property which is set to the number of commands within it which match +this regexp. The idea is that the prover-specific code can create a +customized undo command to retract the goal-save region, based on the +'nestedundos setting. Coq uses this to forget declarations, since +declarations in Coq reside in a separate context with its own (flat) +history." + :type '(choice nil regexp) + :group 'proof-script) + +(defcustom proof-ignore-for-undo-count nil + "Matcher for script commands to be ignored in undo count. +May be left as nil, in which case it will be set to +`proof-non-undoables-regexp'. +Used in default function `proof-generic-count-undos'." + :type '(choice nil regexp function) + :group 'proof-script) + +(defcustom proof-script-next-entity-regexps nil + "Regular expressions to help find definitions and proofs in a script. +This is the list of the form + + (ANYENTITY-REGEXP + DISCRIMINATOR-REGEXP ... DISCRIMINATOR-REGEXP) + +The idea is that ANYENTITY-REGEXP matches any named entity in the +proof script, on a line where the name appears. This is assumed to be +the start or the end of the entity. The discriminators then test +which kind of entity has been found, to get its name. A +DISCRIMINATOR-REGEXP has one of the forms + + (REGEXP MATCHNOS) + (REGEXP MATCHNOS 'backward BACKREGEXP) + (REGEXP MATCHNOS 'forward FORWARDREGEXP) + +If REGEXP matches the string captured by ANYENTITY-REGEXP, then +MATCHNOS are the match numbers for the substrings which name the entity +(these may be either a single number or a list of numbers). + +If 'backward BACKREGEXP is present, then the start of the entity +is found by searching backwards for BACKREGEXP. + +Conversely, if 'forward FORWARDREGEXP is found, then the end of +the entity is found by searching forwards for FORWARDREGEXP. + +Otherwise, the start and end of the entity will be the region matched +by ANYENTITY-REGEXP. + +This mechanism allows fairly complex parsing of the buffer, in +particular, it allows for goal..save regions which are named +only at the end. However, it does not parse strings, +comments, or parentheses. + +This variable may not need to be set: a default value which should +work for goal..saves is calculated from proof-goal-with-hole-regexp, +proof-goal-command-regexp, and proof-save-with-hole-regexp." + :type 'sexp + ;; Bit tricky. + ;; (list (regexp :tag "Any entity matcher") + ;; (:inline t repeat (choice regexp (const 'backward) etc + :group 'proof-script) + +(defcustom proof-script-find-next-entity-fn + 'proof-script-find-next-entity + "Name of function to find next interesting entity in a script buffer. +This is used to configure func-menu. The default value is +proof-script-find-next-entity, which searches for the next entity +based on fume-function-name-regexp which by default is set from +proof-script-next-entity-regexps. + +The function should move point forward in a buffer, and return a cons +cell of the name and the beginning of the entity's region. + +Note that proof-script-next-entity-regexps is set to a default value +from proof-goal-with-hole-regexp and proof-save-with-hole-regexp in +the function proof-config-done, so you may not need to worry about any +of this. See whether function menu does something sensible by +default." + :type 'function + :group 'proof-script) + +;; FIXME da: This next one is horrible. We clearly would rather +;; have just proof-goal-command regexp instead. This was born to solve +;; problem that Coq can have goals which look like definitions, etc. +;; Perhaps we can generalise the matching to understand function +;; values as well as regexps. +;; FIXME: could just as easily give default value of +;; proof-std-goal-command-p here, why not? +(defcustom proof-goal-command-p 'proof-generic-goal-command-p + "A function to test: is this really a goal command? + +This is added as a more refined addition to proof-goal-command-regexp, +to solve the problem that Coq and some other provers can have goals which +look like definitions, etc. (In the future we may generalize +proof-goal-command-regexp instead)." + :type 'function + :group 'proof-script) + +;; FIXME mmw: increasing the horror even more ... +;; FIXME da: why do you need the span below? I would like to replace +;; this mess by single config variables which are allowed to be +;; regexps or functions, handled in proof-string-match. +;; FIXME mmw: the span is required to scan backwards through the text, +;; determining the depth of proof nesting. +;; FIXME da: yuck! What I'd really like to replace the mess with is +;; feedback from the proof assistant, saying "that was a save", etc. +;; FIXME mmw: all we need is some tracking of the 'depth' of commands; +;; Why not let PG track this as in spans, changing the value based +;; on some regexps for 'open' / 'close' commands? This would basically +;; move the code of isar-global-save-command-p to proof-done-advancing. +;; FIXME da: sounds like a good idea, then that would give us a proper +;; handling of nested proofs? +;; +(defcustom proof-really-save-command-p (lambda (span cmd) t) + "Is this really a save command? + +This is a more refined addition to proof-save-command-regexp. +It should be a function taking a span and command as argument, +and can be used to track nested proofs. (See what is done in +isar/ for example). In the future, this setting should be +removed when the generic core is extended to handle nested +proofs smoothly." + :type 'function + :group 'proof-script) + +(defcustom proof-completed-proof-behaviour nil + "Indicates how Proof General treats commands beyond the end of a proof. +Normally goal...save regions are \"closed\", i.e. made atomic for undo. +But once a proof has been completed, there may be a delay before +the \"save\" command appears --- or it may not appear at all. Unless +nested proofs are supported, this can spoil the undo-behaviour in +script management since once a new goal arrives the old undo history +may be lost in the prover. So we allow Proof General to close +off the goal..[save] region in more flexible ways. +The possibilities are: + + nil - nothing special; close only when a save arrives + 'closeany - close as soon as the next command arrives, save or not + 'closegoal - close when the next \"goal\" command arrives + 'extend - keep extending the closed region until a save or goal. + +If your proof assistant allows nested goals, it will be wrong to close +off the portion of proof so far, so this variable should be set to nil. + +NB: 'extend behaviour is not currently compatible with appearance of +save commands, so don't use that if your prover has save commands." + :type '(choice + (const :tag "Close on save only" nil) + (const :tag "Close next command" closeany) + (const :tag "Close next goal" closegoal) + (const :tag "Extend" ignore)) + :group 'proof-script) + +(defcustom proof-count-undos-fn 'proof-generic-count-undos + "Function to calculate a command to issue undos to reach a target span. +The function takes a span as an argument, and should return a string +which is the command to undo to the target span. The target is +guaranteed to be within the current (open) proof. +This is an important function for script management. +The default setting `proof-generic-count-undos' is based on the +settings `proof-non-undoables-regexp' and +`proof-non-undoables-regexp'." + :type 'function + :group 'proof-script) + +; Not yet implemented. +; +;(defcustom proof-atomic-sequence-lists nil +; "list of instructions for setting up atomic sequences of commands (ACS). + +;Each instruction is +;a list of the form `(END START &optional FORGET-COMMAND)'. END is a +;regular expression to recognise the last command in an ACS. START +;is a function. Its input is the last command of an ACS. Its output +;is a regular exression to recognise the first command of the ACS. +;It is evaluated once and the output is successively matched agains +;previously processed commands until a match occurs (or the +;beginning of the current buffer is reached). The region determined +;by (START,END) is locked as an ACS. Optionally, the ACS is +;annotated with the actual command to retract the ACS. This is +;computed by applying FORGET-COMMAND to the first and last command +;of the ACS." +; ;; FIXME customize broken on choices with function in them? +; ;;:type '(repeat (cons regexp function (choice (const nil) function))) +; :type '(repeat (cons regexp function function)) +; :group 'proof-shell) + + +(defconst proof-no-command "COMMENT" + "String used as a nullary action (send no command to the proof assistant). +Only relevant for proof-find-and-forget-fn. +(NB: this is a CONSTANT, don't change it).") + +(defcustom proof-find-and-forget-fn 'proof-generic-find-and-forget + "Function that returns a command to forget back to before its argument span. +This setting is used to for retraction (undoing) in proof scripts. + +It should undo the effect of all settings between its target span +up to (proof-locked-end). This may involve forgetting a number +of definitions, declarations, or whatever. + +The special string proof-no-command means there is nothing to do. + +This is an important function for script management. +Study one of the existing instantiations for examples of how to write it, +or leave it set to the default function `proof-generic-find-and-forget' +(which see)." + :type 'function + :group 'proof-script) + +(defcustom proof-forget-id-command nil + "Command to forget back to a given named span. +A string; `%s' will be replaced by the name of the span. + +This is only used in the implementation of `proof-generic-find-and-forget', +you only need to set if you use that function (by not customizing +`proof-find-and-forget-fn'." + :type 'string + :group 'proof-script) + +(defcustom pg-topterm-goalhyp-fn nil + "Function which returns cons cell if point is at a goal/hypothesis. +This is used to parse the proofstate output to mark it up for +proof-by-pointing. It should return a cons or nil. First element of +the cons is a symbol, 'goal' or 'hyp'. The second element is a +string: the goal or hypothesis itself. + +If you leave this variable unset, no proof-by-pointing markup +will be attempted." + :type '(choice function nil) + :group 'proof-script) + +(defcustom proof-kill-goal-command "" + "Command to kill the currently open goal. + +If this is set to nil, PG will expect proof-find-and-forget-fn +to do all the work of retracting to an arbitrary point in a file. +Otherwise, the generic split-phase mechanism will be used: + + 1. If inside an unclosed proof, use proof-count-undos. + 2. If retracting to before an unclosed proof, use + proof-kill-goal-command, followed by proof-find-and-forget-fn + if necessary." + :type 'string + :group 'proof-script) + +(defcustom proof-undo-n-times-cmd nil + "Command to undo n steps of the currently open goal. +String or function. +If this is set to a string, `%s' will be replaced by the number of +undo steps to issue. +If this is set to a function, it should return the appropriate +command when called with an integer (the number of undo steps). + +This setting is used for the default `proof-generic-count-undos'. +If you set `proof-count-undos-fn' to some other function, there is no +need to set this variable." + :type '(or string function) + :group 'proof-script) + +(defcustom proof-nested-goals-history-p nil + "Whether the prover supports recovery of history for nested proofs. +If it does (non-nil), Proof General will retain history inside +nested proofs. +If it does not, Proof General will amalgamate nested proofs into single +steps within the outer proof." + :type 'boolean + :group 'proof-script) + +(defcustom proof-state-preserving-p 'proof-generic-state-preserving-p + "A predicate, non-nil if its argument (a command) preserves the proof state. +This is a safety-test used by proof-minibuffer-cmd to filter out scripting +commands which should be entered directly into the script itself. + +The default setting for this function, `proof-generic-state-preserving-p' +tests by negating the match on `proof-non-undoables-regexp'." + :type 'function + :group 'proof-script) + +(defcustom proof-activate-scripting-hook nil + "Hook run when a buffer is switched into scripting mode. +The current buffer will be the newly active scripting buffer. + +This hook may be useful for synchronizing with the proof +assistant, for example, to switch to a new theory +(in case that isn't already done by commands in the proof +script). + +When functions in this hook are called, the variable +`activated-interactively' will be non-nil if +proof-activate-scripting was called interactively +(rather than as a side-effect of some other action). +If a hook function sends commands to the proof process, +it should wait for them to complete (so the queue is cleared +for scripting commands), unless activated-interactively is set." + :type '(repeat function) + :group 'proof-script) + +;; +;; Proof script indentation +;; + +(defcustom proof-indent 2 + "Amount of proof script indentation." + :type 'number + :group 'proof-script) + +(defcustom proof-indent-hang nil + "Enable 'hanging' indentation for proof script." + :type 'boolean + :group 'proof-script) + +(defcustom proof-indent-enclose-offset 1 + "Extra offset for enclosing indentation syntax elements." + :type 'number + :group 'proof-script) + +(defcustom proof-indent-open-offset 1 + "Extra offset for opening indentation syntax elements." + :type 'number + :group 'proof-script) + +(defcustom proof-indent-close-offset 1 + "Extra offset for closing indentation syntax elements." + :type 'number + :group 'proof-script) + +(defcustom proof-indent-any-regexp "\\s(\\|\\s)" + "Regexp for *any* syntax element guiding proof script indentation." + :type 'string + :group 'proof-script) + +(defcustom proof-indent-inner-regexp nil + "Regexp for text within syntax elements of proof script indentation." + :type 'string + :group 'proof-script) + +(defcustom proof-indent-enclose-regexp nil + "Regexp for enclosing syntax elements of proof script indentation." + :type 'string + :group 'proof-script) + +(defcustom proof-indent-open-regexp "\\s(" + "Regexp for opening syntax elements of proof script indentation." + :type 'string + :group 'proof-script) + +(defcustom proof-indent-close-regexp "\\s)" + "Regexp for closing syntax elements of proof script indentation." + :type 'string + :group 'proof-script) + + +(defcustom proof-script-font-lock-keywords nil + "Value of font-lock-keywords used to fontify proof scripts. +This is currently used only by proof-easy-config mechanism, +to set font-lock-keywords before calling proof-config-done. +See also proof-{shell,resp,goals}-font-lock-keywords." + :type 'sexp + :group 'proof-script) + + +;; +;; Proof script context menu customization +;; +(defcustom proof-script-span-context-menu-extensions nil + "Extensions for the in-span context sensitive menu. +This should be a function which accepts three arguments: SPAN IDIOM NAME. +See pg-user.el: pg-create-in-span-context-menu for more hints." + :type 'function + :group 'proof-script) + + + + + + +;; +;; 5. Configuration for proof shell +;; +;; The variables in this section concern the proof shell mode. +;; The first group of variables are hooks invoked at various points. +;; The second group of variables are concerned with matching the output +;; from the proof assistant. +;; +;; Variables here are put into the customize group 'proof-shell'. +;; +;; These should be set in the shell mode configuration, again, +;; before proof-shell-config-done is called. +;; + +(defgroup proof-shell nil + "Settings for output from the proof assistant in the proof shell." + :group 'prover-config + :prefix "proof-shell-") + + +;; +;; 5a. commands +;; + +(defcustom proof-prog-name nil + "System command to run the proof assistant in the proof shell. +Suggestion: this can be set in proof-pre-shell-start-hook from +a variable which is in the proof assistant's customization +group. This allows different proof assistants to coexist +\(albeit in separate Emacs sessions)." + :type 'string + :group 'proof-shell) + +(defcustom proof-shell-auto-terminate-commands t + "Non-nil if Proof General should try to add terminator to every command. +If non-nil, whenever a command is sent to the prover using +`proof-shell-invisible-command', Proof General will check to see if it +ends with proof-terminal-char, and add it if not. +If proof-terminal-char is nil, this has no effect." + :type 'boolean + :group 'proof-shell) + +(defcustom proof-shell-pre-sync-init-cmd nil + "The command for configuring the proof process to gain synchronization. +This command is sent before Proof General's synchronization +mechanism is engaged, to allow customization inside the process +to help gain syncrhonization (e.g. engaging special markup). + +It is better to configure the proof assistant for this purpose +via command line options if possible, in which case this variable +does not need to be set. + +See also `proof-shell-init-cmd'." + :type '(choice string (const nil)) + :group 'proof-shell) + +(defcustom proof-shell-init-cmd nil + "The command for initially configuring the proof process. +This command is sent to the process as soon as synchronization is gained +\(when an annotated prompt is first recognized). It can be used to configure +the proof assistant in some way, or print a welcome message +\(since output before the first prompt is discarded). + +See also `proof-shell-pre-sync-init-cmd'." + :type '(choice string (const nil)) + :group 'proof-shell) + +(defcustom proof-shell-restart-cmd "" + "A command for re-initialising the proof process." + :type '(choice string (const nil)) + :group 'proof-shell) + +(defcustom proof-shell-quit-cmd nil + "A command to quit the proof process. If nil, send EOF instead." + :type '(choice string (const nil)) + :group 'proof-shell) + +(defcustom proof-shell-quit-timeout 4 + ;; FIXME could add option to quiz user before rude kill. + "The number of seconds to wait after sending proof-shell-quit-cmd. +After this timeout, the proof shell will be killed off more rudely. +If your proof assistant takes a long time to clean up (for +example writing persistent databases out or the like), you may +need to bump up this value." + :type '(choice string (const nil)) + :group 'proof-shell) + +(defcustom proof-shell-cd-cmd nil + "Command to the proof assistant to change the working directory. +The format character `%s' is replaced with the directory, and +the escape sequences in `proof-shell-filename-escapes' are +applied to the filename. + +This setting is used to define the function proof-cd which +changes to the value of (default-directory) for script buffers. +For files, the value of (default-directory) is simply the +directory the file resides in. + +NB: By default, proof-cd is called from proof-activate-scripting-hook, +so that the prover switches to the directory of a proof +script every time scripting begins." + :type 'string + :group 'proof-shell) + +(defcustom proof-shell-start-silent-cmd nil + "Command to turn prover goals output off when sending many script commands. +If non-nil, Proof General will automatically issue this command +to help speed up processing of long proof scripts. +See also proof-shell-stop-silent-cmd. +NB: terminator not added to command." + :type '(choice string (const nil)) + :group 'proof-shell) + +(defcustom proof-shell-stop-silent-cmd nil + "Command to turn prover output on. +If non-nil, Proof General will automatically issue this command +to help speed up processing of long proof scripts. +See also proof-shell-start-silent-cmd. +NB: Terminator not added to command." + :type '(choice string (const nil)) + :group 'proof-shell) + +(defcustom proof-shell-silent-threshold 2 + "Number of waiting commands in the proof queue needed to trigger silent mode. +Default is 2, but you can raise this in case switching silent mode +on or off is particularly expensive (or make it ridiculously large +to disable silent mode altogether)." + :type 'integer + :group 'proof-shell) + +(defcustom proof-shell-inform-file-processed-cmd nil + "Command to the proof assistant to tell it that a file has been processed. +The format character `%s' is replaced by a complete filename for a +script file which has been fully processed interactively with +Proof General. See `proof-format-filename' for other possibilities +to process the filename. + +This setting used to interface with the proof assistant's internal +management of multiple files, so the proof assistant is kept aware of +which files have been processed. Specifically, when scripting +is deactivated in a completed buffer, it is added to Proof General's +list of processed files, and the prover is told about it by +issuing this command. + +If this is set to nil, no command is issued. + +See also: proof-shell-inform-file-retracted-cmd, +proof-shell-process-file, proof-shell-compute-new-files-list." + :type '(choice string (const nil)) + :group 'proof-shell) + +(defcustom proof-shell-inform-file-retracted-cmd nil + "Command to the proof assistant to tell it that a file has been retracted. +The format character `%s' is replaced by a complete filename for a +script file which Proof General wants the prover to consider as not +completely processed. See `proof-format-filename' for other +possibilities to process the filename. + +This is used to interface with the proof assistant's internal +management of multiple files, so the proof assistant is kept aware of +which files have been processed. Specifically, when scripting +is activated, the file is removed from Proof General's list of +processed files, and the prover is told about it by issuing this +command. The action may cause the prover in turn to suggest to +Proof General that files depending on this one are +also unlocked. + +If this is set to nil, no command is issued. + +See also: proof-shell-inform-file-processed-cmd, +proof-shell-process-file, proof-shell-compute-new-files-list." + :type '(choice string (const nil)) + :group 'proof-shell) + +(defcustom proof-auto-multiple-files nil + "Whether to use automatic multiple file management. +If non-nil, Proof General will automatically retract a script file +whenever another one is retracted which it depends on. It assumes +a simple linear dependency between files in the order which +they were processed. + +If your proof assistant has no management of file dependencies, or one +which depends on a simple linear context, you may be able to use this +setting to good effect. If the proof assistant has more complex +file dependencies then you should configure it to communicate with +Proof General about the dependencies rather than using this setting." + :type 'boolean + :group 'proof-shell) + +;; (defcustom proof-shell-adjust-line-width-cmd nil + + + + + + +;; +;; 5b. Regexp variables for matching output from proof process. +;; + +(defcustom proof-shell-prompt-pattern nil + "Proof shell's value for comint-prompt-pattern, which see. +This pattern is just for interaction in comint (shell buffer). +You don't really need to set it." + :type 'regexp + :group 'proof-shell) + +;; FIXME da: replace this with wakeup-regexp or prompt-regexp? +;; May not need next variable. +(defcustom proof-shell-wakeup-char nil + "A special character which terminates an annotated prompt. +Set to nil if proof assistant does not support annotated prompts." + :type '(choice character (const nil)) + :group 'proof-shell) + +(defcustom proof-shell-annotated-prompt-regexp nil + "Regexp matching a (possibly annotated) prompt pattern. + +THIS IS THE MOST IMPORTANT SETTING TO CONFIGURE!! + +Output is grabbed between pairs of lines matching this regexp, +and the appearance of this regexp is used by Proof General to +recognize when the prover has finished processing a command. + +To help speed up matching you may be able to annotate the +proof assistant prompt with a special character not appearing +in ordinary output. The special character should appear in +this regexp, and should be the value of proof-shell-wakeup-char." + :type 'regexp + :group 'proof-shell) + +(defcustom proof-shell-abort-goal-regexp nil + "Regexp matching output from an aborted proof." + :type 'regexp + :group 'proof-shell) + +(defcustom proof-shell-error-regexp nil + "Regexp matching an error report from the proof assistant. + +We assume that an error message corresponds to a failure in the last +proof command executed. So don't match mere warning messages with +this regexp. Moreover, an error message should not be matched as an +eager annotation (see proof-shell-eager-annotation-start) otherwise it +will be lost. + +Error messages are considered to begin from proof-shell-error-regexp +and continue until the next prompt. The variable +`proof-shell-truncate-before-error' controls whether text before the +error message is displayed. + +The engine matches interrupts before errors, see proof-shell-interrupt-regexp. + +It is safe to leave this variable unset (as nil)." + :type '(choice nil regexp) + :group 'proof-shell) + +(defcustom proof-shell-truncate-before-error t + "Non-nil means truncate output that appears before error messages. +If nil, the whole output that the prover generated before the last +error message will be shown. + +NB: the default setting for this is `t' to be compatible with +behaviour in Proof General before version 3.4. The more obvious +setting for new instances is probably `nil'. + +Interrupt messages are treated in the same way. +See `proof-shell-error-regexp' and `proof-shell-interrupt-regexp'." + :type 'boolean + :group 'proof-shell) + +(defcustom pg-next-error-regexp nil + "Regular expression which matches an error message, perhaps with line/column. +Used by `proof-next-error' to jump to line numbers causing +errors during some batch processing of the proof assistant. +\(During \"manual\" script processing, script usually automatically +jumps to the end of the locked region) + +Match number 2 should be the line number, if present. +Match number 3 should be the column number, if present. + +The filename may be matched by `pg-next-error-filename-regexp', +which is assumed to precede pg-next-error-regexp." + :type 'string + :group 'proof-shell) + +(defcustom pg-next-error-filename-regexp nil + "Used to locate a filename that an error message refers to. +Used by `proof-next-error' to jump to locations causing +errors during some batch processing of the proof assistant. +\(During \"manual\" script processing, the script usually automatically +jumps to the end of the locked region). + +Match number 2 should be the file name, if present. + +Errors must first be matched by `pg-next-error-regexp' +\(whether they contain a line number or not). The response buffer +is then searched *backwards* for a regexp matching this variable, +`pg-next-error-filename-regexp'. (So if the +filename appears after the line number, make the first regexp +match the whole line). Finally +`pg-next-error-extract-filename' +may be used to extract the filename from +This regexp should be set to match messages also matched by +`proof-shell-error-message-line-number-regexp'. +Match number 1 should be the filename." + :type 'string + :group 'proof-shell) + +;; FIXME: generalize this to string-or-function scheme +(defcustom pg-next-error-extract-filename nil + "A string used to extract filename from error message. %s replaced. +NB: this is only used if the match itself does not already correspond +to a filename." + :type 'string + :group 'proof-shell) + +(defcustom proof-shell-interrupt-regexp nil + "Regexp matching output indicating the assistant was interrupted. +We assume that an interrupt message corresponds to a failure in the last +proof command executed. So don't match mere warning messages with +this regexp. Moreover, an interrupt message should not be matched as an +eager annotation (see proof-shell-eager-annotation-start) otherwise it +will be lost. + +The engine matches interrupts before errors, see proof-shell-error-regexp. + +It is safe to leave this variable unset (as nil)." + :type '(choice nil regexp) + :group 'proof-shell) + +(defcustom proof-shell-proof-completed-regexp nil + "Regexp matching output indicating a finished proof. + +When output which matches this regexp is seen, we clear the goals +buffer in case this is not also marked up as a `goals' type of +message. + +We also enable the QED function (save a proof) and we may automatically +close off the proof region if another goal appears before a save +command, depending on whether the prover supports nested proofs or not." + :type '(choice nil regexp) + :group 'proof-shell) + +(defcustom proof-shell-clear-response-regexp nil + "Regexp matching output telling Proof General to clear the response buffer. +This feature is useful to give the prover more control over what output +is shown to the user. Set to nil to disable." + :type '(choice nil regexp) + :group 'proof-shell) + +(defcustom proof-shell-clear-goals-regexp nil + "Regexp matching output telling Proof General to clear the goals buffer. +This feature is useful to give the prover more control over what output +is shown to the user. Set to nil to disable." + :type '(choice nil regexp) + :group 'proof-shell) + +(defcustom proof-shell-start-goals-regexp nil + "Regexp matching the start of the proof state output. +This is an important setting. Output between `proof-shell-start-goals-regexp' +and `proof-shell-end-goals-regexp' will be pasted into the goals buffer +and possibly analysed further for proof-by-pointing markup." + :type '(choice nil regexp) + :group 'proof-shell) + +(defcustom proof-shell-end-goals-regexp nil + "Regexp matching the end of the proof state output, or nil. +If nil, just use the rest of the output following proof-shell-start-goals-regexp." + :type '(choice nil regexp) + :group 'proof-shell) + +(defcustom proof-shell-eager-annotation-start nil + "Eager annotation field start. A regular expression or nil. +An eager annotation indicates to Proof General that some following output +should be displayed (or processed) immediately and not accumulated for +parsing later. + +It is nice to recognize (starts of) warnings or file-reading messages +with this regexp. You must also recognize any special messages +from the prover to PG with this regexp (e.g. `proof-shell-clear-goals-regexp', +`proof-shell-retract-files-regexp', etc.) + +See also `proof-shell-eager-annotation-start-length', +`proof-shell-eager-annotation-end'. + +Set to nil to disable this feature." + :type '(choice regexp (const :tag "Disabled" nil)) + :group 'proof-shell) + +(defcustom proof-shell-eager-annotation-start-length 10 + "Maximum length of an eager annotation start. +Must be set to the maximum length of the text that may match +`proof-shell-eager-annotation-start' (at least 1). +If this value is too low, eager annotations may be lost! + +This value is used internally by Proof General to optimize the process +filter to avoid unnecessary searching." + :type 'integer + :group 'proof-shell) + +(defcustom proof-shell-eager-annotation-end "\n" + "Eager annotation field end. A regular expression or nil. +An eager annotation indicates to Emacs that some following output +should be displayed or processed immediately. + +See also `proof-shell-eager-annotation-start'. + +It is nice to recognize (ends of) warnings or file-reading messages +with this regexp. You must also recognize (ends of) any special messages +from the prover to PG with this regexp (e.g. `proof-shell-clear-goals-regexp', +`proof-shell-retract-files-regexp', etc.) + +The default value is \"\\n\" to match up to the end of the line." + :type '(choice regexp (const :tag "Unset" nil)) + :group 'proof-shell) + +(defcustom proof-shell-assumption-regexp nil + "A regular expression matching the name of assumptions. + +At the moment, this setting is not used in the generic Proof General. + +In the future it will be used for a generic implementation for `pg-topterm-goalhyp-fn', +used to help parse the goals buffer to annotate it for proof by pointing." + :type '(choice regexp (const :tag "Unset" nil)) + :group 'proof-shell) + +(defcustom proof-shell-process-file nil + "A pair (REGEXP . FUNCTION) to match a processed file name. + +If REGEXP matches output, then the function FUNCTION is invoked on the +output string chunk. It must return the name of a script file (with +complete path) that the system has successfully processed. In +practice, FUNCTION is likely to inspect the match data. If it returns +the empty string, the file name of the scripting buffer is used +instead. If it returns nil, no action is taken. + +Care has to be taken in case the prover only reports on compiled +versions of files it is processing. In this case, FUNCTION needs to +reconstruct the corresponding script file name. The new (true) file +name is added to the front of `proof-included-files-list'." + :type '(choice (cons regexp function) (const nil)) + :group 'proof-shell) + + +;; FIXME da: why not amalgamate the next two into a single +;; variable as above? Maybe because removing one +;; + +(defcustom proof-shell-retract-files-regexp nil + "Matches a message that the prover has retracted a file. + +At this stage, Proof General's view of the processed files is out of +date and needs to be updated with the help of the function +`proof-shell-compute-new-files-list'." + :type '(choice regexp (const nil)) + :group 'proof-shell) + +(defcustom proof-shell-compute-new-files-list nil + "Function to update `proof-included-files list'. + +It needs to return an up to date list of all processed files. Its +output is stored in `proof-included-files-list'. Its input is the +string of which `proof-shell-retract-files-regexp' matched a +substring. In practice, this function is likely to inspect the +previous (global) variable `proof-included-files-list' and the match +data triggered by `proof-shell-retract-files-regexp'." + :type '(choice function (const nil)) + :group 'proof-shell) + +(defcustom pg-use-specials-for-fontify nil + "Flag indicating whether to strip annotations from output or not. +\"annotations\" are special characters with the top bit set. +If annotations are left in, they are made invisible and can be used +to do syntax highlighting with font-lock." + :type 'boolean + :group 'proof-shell) + +(defcustom proof-shell-set-elisp-variable-regexp nil + "Matches output telling Proof General to set some variable. +This allows the proof assistant to configure Proof General directly +and dynamically. + +If the regexp matches output from the proof assistant, there should be +two match strings: (match-string 1) should be the name of the elisp +variable to be set, and (match-string 2) should be the value of the +variable (which will be evaluated as a lisp expression). + +A good markup for the second string is to delimit with #'s, since +these are not valid syntax for elisp evaluation. + +Elisp errors will be trapped when evaluating; set +proof-show-debug-messages to be informed when this happens. + +Example uses are to adjust PG's internal copies of proof assistant's +settings, or to make automatic dynamic syntax adjustments in Emacs to +match changes in theory, etc. + +If you pick a dummy variable name (e.g. `proof-dummy-setting') you +can just evaluation arbitrary elisp expressions for their side +effects, to adjust menu entries, or even launch auxiliary programs. +But use with care -- there is no protection against catastrophic elisp! + +This setting could also be used to move some configuration settings +from PG to the prover, but this is not really supported (most settings +must be made before this mechanism will work). In future, the PG +standard protocol, PGIP, will use this mechanism for making all +settings." + :type '(choice nil regexp) + :group 'proof-shell) + +(defcustom proof-shell-match-pgip-cmd nil + "Regexp used to match PGIP command from proof assistant. +The matching string will be parsed as XML and then processed by +`pg-pgip-process-cmd'." + :type '(choice nil regexp) + :group 'proof-shell) + +;; FIXME: next one needs changing to be a function, or have function +;; built from it. +(defcustom proof-shell-issue-pgip-cmd nil + "Command sent to prover to process PGIP command in %s placeholder." + :type '(choice nil string) + :group 'proof-shell) + + +;; FIXME FIXME: this next one not yet used. It's hard to interleave +;; commands with the ordinary queue anyway: the prover should +;; automatically output this information if it is enabled. +(defcustom proof-shell-query-dependencies-cmd nil + "Command to query the prover for dependencies of given theorem name. +%s is replaced by the name of the theorem. This command will be +sent when a proof is completed." + :type 'string + :group 'proof-shell) + +(defcustom proof-shell-theorem-dependency-list-regexp nil + "Matches output telling Proof General about dependencies. +This is to allow navigation and display of dependency information. +The output from the prover should be a message with the form + + DEPENDENCIES OF X Y Z ARE A B C + +with X Y Z, A B C separated by whitespace or somehow else (see +`proof-shell-theorem-dependency-list-split'. This variable should +be set to a regexp to match the overall message (which should +be an urgent message), with two sub-matches for X Y Z and A B C. + +This is an experimental feature, currently work-in-progress." + :type '(choice nil regexp) + :group 'proof-shell) + +(defcustom proof-shell-theorem-dependency-list-split nil + "Splits strings which match `proof-shell-theorem-dependency-list-regexp'. +Used as an argument to `split-string'; nil defaults to whitespace. +\(This setting is necessary for provers which allow whitespace in +the names of theorems/definitions/constants), see setting for +Isabelle in isa/isa.el and isar/isar.el." + :type '(choice nil regexp) + :group 'proof-shell) + +(defcustom proof-shell-show-dependency-cmd nil + "Command sent to the prover to display a dependency. +This is typically a command used to print a theorem, constant, or whatever. +A string with %s replaced by the dependency name." + :type 'string + :group 'proof-shell) + +(defcustom proof-shell-trace-output-regexp nil + "Matches tracing output which should be displayed in trace buffer. +Each line which matches this regexp but would otherwise be treated +as an ordinary response, is sent to the trace buffer instead of the +response buffer. + +This is intended for unusual debugging output from +the prover, rather than ordinary output from final proofs. + +Set to nil to disable. + +Suggestion: this can be set a function called by `proof-pre-shell-start-hook'." + :type '(choice nil regexp) + :group 'proof-shell) + + +(defcustom proof-shell-thms-output-regexp nil + "Matches theorem display which should be displayed in theorem buffer. +Each line which matches this regexp but would otherwise be treated +as an ordinary response, is sent to the theorem buffer as well as the +response buffer." + :type '(choice nil regexp) + :group 'proof-shell) + +;; +;; 5c. hooks and other miscellaneous customizations +;; + +(defcustom proof-shell-filename-escapes nil + "A list of escapes that are applied to %s for filenames. +A list of cons cells, car of which is string to be replaced +by the cdr. +For example, when directories are sent to Isabelle, HOL, and Coq, +they appear inside ML strings and the backslash character and +quote characters must be escaped. The setting + '((\"\\\\\\\\\" . \"\\\\\\\\\") + (\"\\\"\" . \"\\\\\\\"\")) +achieves this. This does not apply to LEGO, which does not +need backslash escapes and does not allow filenames with +quote characters. + +This setting is used inside the function `proof-format-filename'." + :type '(list (cons string string)) + :group 'proof-shell) + +(defcustom proof-shell-process-connection-type + ;; Use ptys unless it seems like we're on Solaris. Only have + ;; a good chance to guess if shell-command-to-string and uname + ;; available. + (if (and + (not (fboundp 'win32-long-file-name)) + (fboundp 'shell-command-to-string)) + (not (string-match "[sS]un" (shell-command-to-string "uname"))) + t) + "The value of process-connection-type for the proof shell. +Set non-nil for ptys, nil for pipes. +The default (and preferred) option is to use pty communication. +However there is a long-standing backslash/long line problem with +Solaris which gives a mess of ^G characters when some input is sent +which has a \ in the 256th position. +So we select pipes by default if it seems like we're on Solaris. +We do not force pipes everywhere because this risks loss of data." + :type 'boolean + :group 'proof-shell) + +(defcustom proof-shell-strip-crs-from-input t + "If non-nil, replace carriage returns in every input with spaces. +This is enabled by default: it is appropriate for some systems +because several CR's can result in several prompts, which may mess +up the display (or even worse, the synchronization)." + :type 'boolean + :group 'proof-shell) + +(defcustom proof-shell-strip-crs-from-output (eq system-type 'cygwin32) + ;; Cygwin32 probs with Isabelle noted by Norbert Voelker + "If non-nil, remove carriage returns (^M) at the end of lines from output. +This is enabled for cygwin32 systems by default. You should turn it off +if you don't need it (slight speed penalty)." + :type 'boolean + :group 'proof-shell) + +(defcustom proof-shell-insert-hook nil + "Hooks run by proof-shell-insert before inserting a command. +Can be used to configure the proof assistant to the interface in +various ways -- for example, to observe or alter the commands sent to +the prover, or to sneak in extra commands to configure the prover. + +This hook is called inside a save-excursion with the proof-shell-buffer +current, just before inserting and sending the text in the +variable `string'. The hook can massage `string' or insert additional +text directly into the proof-shell-buffer. +Before sending `string', it will be stripped of carriage returns. + +Additionally, the hook can examine the variable `action'. It will be +a symbol, set to the callback command which is executed in the proof +shell filter once `string' has been processed. The `action' variable +suggests what class of command is about to be inserted: + + 'proof-done-invisible A non-scripting command + 'proof-done-advancing A \"forward\" scripting command + 'proof-done-retracting A \"backward\" scripting command + +Caveats: You should be very careful about setting this hook. Proof +General relies on a careful synchronization with the process between +inputs and outputs. It expects to see a prompt for each input it +sends from the queue. If you add extra input here and it causes more +prompts than expected, things will break! Extending the variable +`string' may be safer than inserting text directly, since it is +stripped of carriage returns before being sent. + +Example uses: +LEGO uses this hook for setting the pretty printer width if +the window width has changed; +Plastic uses it to remove literate-style markup from `string'. +The x-symbol support uses this hook to convert special characters +into tokens for the proof assistant." + :type '(repeat function) + :group 'proof-shell) + +(defcustom proof-pre-shell-start-hook nil + "Hooks run before proof shell is started. +Suggestion: set this to a function which configures just these proof +shell variables: + + proof-prog-name + proof-mode-for-shell + proof-mode-for-response + proof-mode-for-goals + proof-shell-trace-output-regexp + +This is the bare minimum needed to get a shell buffer and +its friends configured in the function proof-shell-start." + :type '(repeat function) + :group 'proof-shell) + +(defcustom proof-shell-handle-delayed-output-hook + '(proof-pbp-focus-on-first-goal) + "Hooks run after new output has been displayed in goals or response buffer." + :type '(repeat function) + :group 'proof-shell) + +(defcustom proof-shell-handle-error-or-interrupt-hook + '(proof-goto-end-of-locked-if-pos-not-visible-in-window) + "Run after an error or interrupt has been reported in the response buffer. +Hook functions may inspect `proof-shell-error-or-interrupt-seen' to +determine whether the cause was an error or interrupt." + :type '(repeat function) + :group 'proof-shell) + +(defcustom proof-shell-pre-interrupt-hook + nil + "Run immediately after `comint-interrupt-subjob' is called. +This hook is added to allow customization for Poly/ML and other +systems where the system queries the user before returning to +the top level. For Poly/ML it can be used to send the string \"f\", +for example." + :type '(repeat function) + :group 'proof-shell) + +(defcustom proof-shell-process-output-system-specific nil + "Set this variable to handle system specific output. +Errors, start of proofs, abortions of proofs and completions of +proofs are recognised in the function `proof-shell-process-output'. +All other output from the proof engine is simply reported to the +user in the RESPONSE buffer. + +To catch further special cases, set this variable to a pair of +functions '(condf . actf). Both are given (cmd string) as arguments. +`cmd' is a string containing the currently processed command. +`string' is the response from the proof system. To change the +behaviour of `proof-shell-process-output', (condf cmd string) must +return a non-nil value. Then (actf cmd string) is invoked. + +See the documentation of `proof-shell-process-output' for the required +output format." + :type '(repeat function) + :group 'proof-shell) + +(defcustom proof-state-change-hook nil + "This hook is called when state change may have occurred. +Specifically, this hook is called after a region has been asserted or +retracted, or after a command has been sent to the prover with +proof-shell-invisible-command. + +This hook is used within Proof General to refresh the toolbar." + + :type '(repeat function) + :group 'proof-shell) + +(defcustom proof-shell-font-lock-keywords nil + "Value of font-lock-keywords used to fontify the proof shell. +This is currently used only by proof-easy-config mechanism, to set +`font-lock-keywords' before calling `proof-config-done'. +See also proof-{script,resp,goals}-font-lock-keywords." + :type 'sexp + :group 'proof-shell) + + + +;; +;; 6. Goals buffer +;; + +(defgroup proof-goals nil + "Settings for configuring the goals buffer." + :group 'prover-config + :prefix "pg-goals-") + +(defcustom pg-subterm-first-special-char nil + "First special character. +Codes above this character can have special meaning to Proof General, +and are stripped from the prover's output strings. +Leave unset if no special characters are being used." + :type '(choice character (const nil)) + :group 'proof-goals) + +(defcustom pg-subterm-anns-use-stack nil + "Choice of syntax tree encoding for terms. + +If nil, prover is expected to make no optimisations. +If non-nil, the pretty printer of the prover only reports local changes. +For LEGO 1.3.1 use `nil', for Coq 6.2, use `t'." + :type 'boolean + :group 'proof-goals) + +(defcustom pg-goals-change-goal nil + "Command to change to the goal `%s'" + :type 'string + :group 'proof-goals) + +(defcustom pbp-goal-command nil + "Command sent when `pg-goals-button-action' is requested on a goal." + :type '(choice nil string) + :group 'proof-goals) + +(defcustom pbp-hyp-command nil + "Command sent when `pg-goals-button-action' is requested on an assumption." + :type '(choice nil string) + :group 'proof-goals) + +(defcustom pg-subterm-help-cmd nil + "Command to display mouse help about a subterm. +This command is sent to the proof assistant, replacing %s by the +subterm that the mouse is over." + :type '(choice nil string) + :group 'proof-goals) + +(defcustom pg-goals-error-regexp nil + "Regexp indicating that the proof process has identified an error." + :type '(choice nil regexp) + :group 'proof-goals) + +(defcustom proof-shell-result-start nil + "Regexp matching start of an output from the prover after pbp commands. +In particular, after a `pbp-goal-command' or a `pbp-hyp-command'." + :type '(choice nil regexp) + :group 'proof-goals) + +(defcustom proof-shell-result-end "" + "Regexp matching end of output from the prover after pbp commands. +In particular, after a `pbp-goal-command' or a `pbp-hyp-command'." + :type 'regexp + :group 'proof-goals) + +(defcustom pg-subterm-start-char nil + "Opening special character for subterm markup. +Subsequent special characters with values *below* +pg-subterm-first-special-char are assumed to be subterm position +indicators. Annotations should be finished with pg-subterm-sep-char; +the end of the concrete syntax is indicated by pg-subterm-end-char. + +If `pg-subterm-start-char' is nil, subterm markup is disabled. + +See doc of `pg-goals-analyse-structure' for more details of +subterm and proof-by-pointing markup mechanisms.." + :type '(choice character (const nil)) + :group 'proof-goals) + +(defcustom pg-subterm-sep-char nil + "Finishing special for a subterm markup. +See doc of `pg-subterm-start-char'." + :type '(choice character (const nil)) + :group 'proof-goals) + +(defcustom pg-subterm-end-char nil + "Closing special character for subterm markup. +See `pg-subterm-start-char'." + :type 'character + :group 'proof-goals) + +(defcustom pg-topterm-char nil + "Annotation character that indicates the beginning of a \"top\" element. +A \"top\" element may be a sub-goal to be proved or a named hypothesis, +for example. It is currently assumed (following LEGO/Coq conventions) +to span a whole line. + +The function `pg-topterm-goalhyp-fn' examines text following this +special character, to determine what kind of top element it is. + +This setting is also used to see if proof-by-pointing features +are configured. If it is unset, some of the code +for parsing the prover output is disabled." + :type 'character + :group 'proof-goals) + + + +(defcustom proof-goals-font-lock-keywords nil + "Value of font-lock-keywords used to fontify the goals output. +NB: the goals output is not kept in font-lock-mode because the +fontification may rely on annotations which are erased before +displaying. This means internal functions of PG must be used +to display to the goals buffer to ensure fontification is done! +This is currently used only by proof-easy-config mechanism, +to set font-lock-keywords before calling proof-config-done. +See also proof-{script,shell,resp}-font-lock-keywords." + :type 'sexp + :group 'proof-goals) + +;; FIXME: perhaps we need new customize group here, "goals" is +;; not quite right for response buffer! +(defcustom proof-resp-font-lock-keywords nil + "Value of font-lock-keywords used to fontify the response output. +NB: the goals output is not kept in font-lock-mode because the +fontification may rely on annotations which are erased before +displaying. This means internal functions of PG must be used +to display to the goals buffer to ensure fontification is done! +This is currently used only by proof-easy-config mechanism, +to set font-lock-keywords before calling proof-config-done. +See also proof-{script,shell,resp}-font-lock-keywords." + :type 'sexp + :group 'proof-goals) + +(defcustom pg-before-fontify-output-hook nil + "This hook is called before fontifying a region in an output buffer. +A function on this hook can alter the region of the buffer within +the current restriction, and must return the final value of (point-max). +[This hook is presently only used by phox-sym-lock]." + :type '(repeat function) + :group 'proof-goals) + +(defcustom pg-after-fontify-output-hook nil + "This hook is called before fonfitying a region in an output buffer. +[This hook is presently only used by Isabelle]." + :type '(repeat function) + :group 'proof-goals) + + + +;; +;; 8. X-Symbol configuration +;; + +(defgroup proof-x-symbol nil + "Configuration of X-Symbol for Proof General." + :group 'prover-config + :prefix "proof-xsym-") + +(defcustom proof-xsym-extra-modes nil + "List of additional mode names to use X-Symbol with Proof General tokens. +These modes will have X-Symbol enabled for the proof assistant token language, +in addition to the four modes for Proof General (script, shell, response, pbp). + +Set this variable if you want additional modes to also display +tokens (for example, editing documentation or source code files)." + :type '(repeat symbol) + :group 'proof-x-symbol) + +;; FIXME: should perhaps be one of these per prover +;; FIXME: actually this setting doesn't seem to be needed: +;; instead X-Symbol uses x-symbol-<lang>-font-lock-keywords. +(defcustom proof-xsym-font-lock-keywords nil + "Font lock keywords to use for the proof assistants X-Symbol token language. +This should be set to the additional font-lock-keywords used for the +proof assistant when X-Symbol is enabled. (For example, additional +keywords used for bold or superscript text: see isa/x-symbol-isabelle.el)" + :type 'sexp + :group 'proof-x-symbol) + +(defcustom proof-xsym-activate-command nil + "Command to activate token input/output for X-Symbol. +If non-nil, this command is sent to the proof assistant when +X-Symbol support is activated." + :type 'string + :group 'proof-x-symbol) + +(defcustom proof-xsym-deactivate-command nil + "Command to deactivate token input/output for X-Symbol. +If non-nil, this command is sent to the proof assistant when +X-Symbol support is deactivated." + :type 'string + :group 'proof-x-symbol) + +(defpgcustom x-symbol-language proof-assistant-symbol + "Setting for x-symbol-language for the current proof assistant. +It defaults to proof-assistant-symbol, which makes X Symbol +look for files named x-symbol-<PA>.el.") + + + + +;; +;; 9. Prover specific settings +;; +;; The settings defined here automatically use the current proof +;; assistant symbol as a prefix, i.e. isa-favourites, coq-favourites, +;; or whatever will be defined on evaluation. + +(defpgcustom favourites nil + "*Favourite commands for this proof assistant. +A list of lists of the form (COMMAND INSCRIPT MENUNAME KEY), +arguments for `proof-add-favourite', which see.") + +(defpgcustom menu-entries nil + "Extra entries for proof assistant specific menu. +A list of menu items [NAME CALLBACK ENABLER ...]. See the documentation +of `easy-menu-define' for more details." + :type 'sexp + :group 'prover-config) + +(defpgcustom help-menu-entries nil + "Extra entries for help submenu for proof assistant specific help menu. +A list of menu items [NAME CALLBACK ENABLER ...]. See the documentation +of `easy-menu-define' for more details." + :type 'sexp + :group 'prover-config) + +(defpgcustom keymap (make-keymap (concat proof-assistant " keymap")) + "Proof assistant specific keymap, used under prefix C-c a." + :type 'sexp + :group 'prover-config) + +(defpgcustom completion-table nil + "List of identifiers to use for completion for this proof assistant. +Completion is activated with \\[complete]. + +If this table is empty or needs adjusting, please make changes using +`customize-variable' and send suggestions to support@@proofgeneral.org" + :type '(list string) + :group 'prover-config) + +;; FIXME: not used yet. +(defpgcustom tags-program nil + "Program to run to generate TAGS table for proof assistant." + :type 'file + :group 'prover-config) + + + + + +;; +;; 10. Global constants + +(defcustom proof-general-name "Proof-General" + "Proof General name used internally and in menu titles." + :type 'string + :group 'proof-general-internals) + +(defcustom proof-general-home-page + "http://www.proofgeneral.org" + "*Web address for Proof General" + :type 'string + :group 'proof-general-internals) + +(defcustom proof-unnamed-theorem-name + "Unnamed_thm" + "A name for theorems which are unnamed. Used internally by Proof General." + :type 'string + :group 'proof-general-internals) + +;; FIXME: da: could we put these into another keymap shared across the +;; various PG modes? +(defcustom proof-universal-keys + (cons + (if proof-running-on-XEmacs + '([(control c) \`] . proof-next-error) + '("`" . proof-next-error)) + '(([(control c) (control c)] . proof-interrupt-process) + ([(control c) (control v)] . proof-minibuffer-cmd) + ([(control c) (control w)] . pg-response-clear-displays))) +"List of key-bindings made for the script, goals and response buffer. +Elements of the list are tuples `(k . f)' +where `k' is a key-binding (vector) and `f' the designated function." + :type 'sexp + :group 'proof-general-internals) + + + + + + +;; End of proof-config.el +(provide 'proof-config) diff --git a/generic/proof-depends.el b/generic/proof-depends.el new file mode 100644 index 00000000..57500bc8 --- /dev/null +++ b/generic/proof-depends.el @@ -0,0 +1,266 @@ +;; proof-depends.el Theorem-theorem and theorem-definition dependencies. +;; +;; Copyright (C) 2000-2002 University of Edinburgh. +;; Authors: David Aspinall <da@dcs.ed.ac.uk> +;; Earlier version by Fiona McNeil. +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; Status: Experimental code +;; +;; $Id$ +;; +;; Based on Fiona McNeill's MSc project on analysing dependencies +;; within proofs. Code rewritten by David Aspinall. +;; + +(require 'span) + +;; Variables + +(defvar proof-thm-names-of-files nil + "A list of file and theorems contained within. +A list of lists; the first element of each list is a file-name, the +second element a list of all the thm names in that file. +i.e.: ((file-name-1 (thm1 thm2 thm3)) (file-name-2 (thm1 thm2 thm3)))") + +(defvar proof-def-names-of-files nil + "A list of files and defs contained within. +A list of lists; the first element of each list is a file-name, the +second element a list of all the def names in that file. +i.e.: ((file-name-1 (def1 def2 def3)) (file-name-2 (def1 def2 def3)))") + + +;; Utility functions + +(defun proof-depends-module-name-for-buffer () + "Return a module name for the current buffer. +This is a name that the prover prefixes all item names with. +For example, in isabelle, a file Stuff.ML contains theorems with +fully qualified names of the form Stuff.theorem1, etc. +For other provers, this function may need modifying." + (if buffer-file-name + (file-name-nondirectory + (file-name-sans-extension buffer-file-name)) "")) + +(defun proof-depends-module-of (name) + "Return a pair of a module name and base name for a given item name. +Assumes module name is given by dotted prefix." + (let ((dot (string-match "\\." name))) + (if dot + (cons (substring name 0 dot) (substring name (+ dot 1))) + (cons "" name)))) + +(defun proof-depends-names-in-same-file (names) + "Return subset of list NAMES which are guessed to occur in same file. +This is done using `proof-depends-module-name-for-buffer' and +`proof-depends-module-of'." + (let ((filemod (proof-depends-module-name-for-buffer)) + samefile) + (while names + (let ((splitname (proof-depends-module-of (car names)))) + (if (equal filemod (car splitname)) + (setq samefile (cons (cdr splitname) samefile)))) + (setq names (cdr names))) + ;; NB: reversed order + samefile)) + + +;; +;; proof-depends-process-dependencies: the main entry point. +;; +;;;###autoload +(defun proof-depends-process-dependencies (name gspan) + "Process dependencies reported by prover, for NAME in span GSPAN. +Called from `proof-done-advancing' when a save is processed and +proof-last-theorem-dependencies is set." + + (set-span-property gspan 'dependencies + ;; Ancestors of NAME are in the second component. + ;; FIXME: for now we ignore the first component: + ;; NAME may not be enough [Isar allows proof regions + ;; with multiple names, which are reported in dep'c'y + ;; output]. + (cdr proof-last-theorem-dependencies)) + + (let* ((samefilenames (proof-depends-names-in-same-file + (cdr proof-last-theorem-dependencies))) + + ;; Find goalsave spans earlier in this file which this + ;; one depends on; update their list of dependents, + ;; and return resulting list paired up with names. + (depspans + (apply 'append + (mapcar-spans + (lambda (depspan) + (let ((dname (span-property depspan 'name))) + (if (and + (eq (span-property depspan 'type) 'goalsave) + (member dname samefilenames)) + (let ((forwarddeps + (span-property depspan 'dependents))) + (set-span-property depspan 'dependents + (cons + (list name gspan) forwarddeps)) + ;; return list of args for menu fun: name and span + (list (list dname depspan)))))) + (point-min) + (span-start gspan) + 'type)))) + + (set-span-property gspan 'dependencies-within-file depspans) + (setq proof-last-theorem-dependencies nil))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Menu Functions +;; +;; The following functions set up the menus which are the key way in +;; which the dependency information is used. + + +;;;###autoload +(defun proof-dependency-in-span-context-menu (span) + "Make a portion of a context-sensitive menu showing proof dependencies." + ;; FIXME: might only activate this for dependency-relevant spans. + (list + "-------------" + (proof-dep-make-submenu "Local Dependency..." + (lambda (namespan) (car namespan)) + 'proof-goto-dependency + (span-property span 'dependencies-within-file)) + (proof-make-highlight-depts-menu "Highlight Dependencies" + 'proof-highlight-depcs + span 'dependencies-within-file) + (proof-dep-make-submenu "Local Dependents..." + (lambda (namepos) (car namepos)) + 'proof-goto-dependency + (span-property span 'dependents)) + (proof-make-highlight-depts-menu "Highlight Dependents" + 'proof-highlight-depts + span 'dependents) + ["Unhighlight all" proof-dep-unhighlight t] + "-------------" + (proof-dep-alldeps-menu span))) + +(defun proof-dep-alldeps-menu (span) + (or (span-property span 'dependencies-menu) ;; cached value + (set-span-property span 'dependencies-menu + (proof-dep-make-alldeps-menu + (span-property span 'dependencies))))) + +(defun proof-dep-make-alldeps-menu (deps) + (let ((menuname "All Dependencies...") + (showdep 'proof-show-dependency)) + (if deps + (let ((nestedtop (proof-dep-split-deps deps))) + (cons menuname + (append + (mapcar (lambda (l) + (vector l (list showdep l) t)) + (cdr nestedtop)) + (mapcar (lambda (sm) + (proof-dep-make-submenu (car sm) + 'car + 'proof-show-dependency + (mapcar 'list (cdr sm)))) + (car nestedtop))))) + (vector menuname nil nil)))) + +(defun proof-dep-split-deps (deps) + "Split dependencies into named nested lists according to dotted prefixes." + ;; NB: could handle deeper nesting here, but just do one level for now. + (let (nested toplevel) + ;; Add each name into a nested list or toplevel list + (mapcar + (lambda (name) + (let* ((period (string-match "\\." name)) + (ns (and period (substring name 0 period))) + (subitems (and ns (assoc ns nested)))) + (cond + ((and ns subitems) + (setcdr subitems (adjoin name (cdr subitems)))) + (ns + (setq nested + (cons (cons ns (list name)) nested))) + (t + (setq toplevel (adjoin name toplevel)))))) + deps) + (cons nested toplevel))) + +(defun proof-dep-make-submenu (name namefn appfn list) + "Make menu items for a submenu NAME, using appfn applied to each elt in LIST. +If LIST is empty, return a disabled menu item with NAME." + (if list + (cons name + (mapcar `(lambda (l) + (vector (,namefn l) + (cons (quote ,appfn) l) t)) list)) + (vector name nil nil))) + +(defun proof-make-highlight-depts-menu (name fn span prop) + "Return a menu item that for highlighting dependents/depencies of SPAN." + (let ((deps (span-property span prop))) + (vector name `(,fn ,(span-property span 'name) (quote ,deps)) (not (not deps))))) + + +;; +;; Functions triggered by menus +;; + +(defun proof-goto-dependency (name span) + ;; FIXME: check buffer is right one. Later we'll allow switching buffer + ;; here and jumping to different files. + (goto-char (span-start span)) + (skip-chars-forward " \t\n")) + +(defun proof-show-dependency (thm) + "Show dependency THM using `proof-show-dependency-cmd'. +This is simply to display the dependency somehow." + (if proof-shell-show-dependency-cmd ;; robustness + (proof-shell-invisible-command + (format proof-shell-show-dependency-cmd thm)))) + +(defconst pg-dep-span-priority 500) +(defconst pg-ordinary-span-priority 100) + +(defun proof-highlight-depcs (name nmspans) + (let ((helpmsg (concat "This item is a dependency (ancestor) of " name))) + (while nmspans + (let ((span (cadar nmspans))) + (set-span-property span 'face 'proof-highlight-dependency-face) + (set-span-property span 'priority pg-dep-span-priority) + (set-span-property span 'mouse-highlight nil) + (set-span-property span 'help-echo helpmsg)) + (setq nmspans (cdr nmspans))))) + +(defun proof-highlight-depts (name nmspans) + (let ((helpmsg (concat "This item depends on (is a child of) " name))) + (while nmspans + (let ((span (cadar nmspans))) + (set-span-property span 'face 'proof-highlight-dependent-face) + (set-span-property span 'priority pg-dep-span-priority) + (set-span-property span 'mouse-highlight nil) + (set-span-property span 'help-echo helpmsg) + (set-span-property span 'balloon-help helpmsg)) + (setq nmspans (cdr nmspans))))) + +(defun proof-dep-unhighlight () + "Returned all highlighted spans in file to the proof-locked-face highlighting." + (interactive) + ;; FIXME: not quite right! Will highlight spans in queue as locked too, + ;; and covers too many spans. + (save-excursion + (let ((span (span-at (point-min) 'type))) + (while span + (pg-set-span-helphighlights span 'nohighlight) + (set-span-property span 'face 'proof-locked-face) + (set-span-property span 'priority pg-ordinary-span-priority) + (setq span (next-span span 'type)))))) + + + + +(provide 'proof-depends) +;; proof-depends.el ends here diff --git a/generic/proof-easy-config.el b/generic/proof-easy-config.el new file mode 100644 index 00000000..878d4669 --- /dev/null +++ b/generic/proof-easy-config.el @@ -0,0 +1,84 @@ +;; proof-easy-config.el Easy configuration for Proof General +;; +;; Copyright (C) 1999-2002 David Aspinall / LFCS. +;; Author: David Aspinall <da@dcs.ed.ac.uk> +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; Future version might copy settings instead; consider how best to +;; interface with customization mechanism so a new prover can be +;; configured by editing inside custom buffers. +;; +(require 'proof) + +(defvar proof-easy-config-derived-modes-table + '(("" "script" proof-mode (proof-config-done)) + ("shell" "shell" proof-shell-mode (proof-shell-config-done)) + ("response" "response" proof-response-mode (proof-response-config-done)) + ("goals" "goals" proof-goals-mode (proof-goals-config-done))) + "A list of (PREFIXSYM SUFFIXNAME PARENT MODEBODY) for derived modes.") + +(defun proof-easy-config-define-derived-modes () + (dolist (modedef proof-easy-config-derived-modes-table) + (let* ((prefixsym (nth 0 modedef)) + (suffixnm (nth 1 modedef)) + (parent (nth 2 modedef)) + (body (nthcdr 3 modedef)) + (modert (concat (symbol-name proof-assistant-symbol) + "-" prefixsym)) + (hyphen (if (string-equal prefixsym "") "" "-")) + (mode (intern (concat modert hyphen "mode"))) + (modename (concat proof-assistant " " suffixnm)) + (varname (intern (concat "proof-mode-for-" suffixnm))) + ;; FIXME: declare these variables in proof-config: + ;; proof-script-font-lock-keywords, etc. + ;; proof-script-syntax-table-entries, etc. + ;; FIXME: in future versions, use these settings in *-config-done + ;; to simplify elisp code elsewhere. + (fntlcks (intern (concat "proof-" suffixnm "-font-lock-keywords"))) + (modsyn (intern (concat "proof-" suffixnm "-syntax-table-entries"))) + (fullbody (append + (if (boundp fntlcks) + (list `(setq font-lock-keywords ,fntlcks))) + (if (boundp modsyn) + (list `(let ((syn ,modsyn)) + (while syn + (modify-syntax-entry + (car syn) (cadr syn)) + (setq syn (cddr syn)))))) + body))) + (eval + `(define-derived-mode ,mode ,parent ,modename nil ,@fullbody)) + ;; Set proof-mode-for-script and friends + ;; NB: top-level, so we don't need proof-pre-shell-start-hook. + (set varname mode)))) + +(defun proof-easy-config-check-setup (sym name) + "A number of simple checks." + (cond + ((or + (and (boundp 'proof-assistant) proof-assistant + (not (equal proof-assistant "")) + (not (equal proof-assistant name))) + (and (boundp 'proof-assistant-symbol) proof-assistant-symbol + (not (eq proof-assistant-symbol sym)))) + (error "proof-easy-config: Proof General is already in use for a different prover!")) + (t + ;; Setting these here is nice for testing: no need to get + ;; proof-assistant-table right first. + (customize-set-variable 'proof-assistant name) + (customize-set-variable 'proof-assistant-symbol sym)))) + +;;;###autoload +(defmacro proof-easy-config (sym name &rest body) + "Configure Proof General for proof-assistant using BODY as a setq body." + `(progn + (proof-easy-config-check-setup ,sym ,name) + (setq + ,@body) + (proof-easy-config-define-derived-modes))) + +;; +(provide 'proof-easy-config) + diff --git a/generic/proof-indent.el b/generic/proof-indent.el new file mode 100644 index 00000000..ffcf6510 --- /dev/null +++ b/generic/proof-indent.el @@ -0,0 +1,91 @@ +;; proof-indent.el Generic Indentation for Proof Assistants +;; +;; Authors: Markus Wenzel +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; + +(require 'proof) ; loader +(require 'proof-script) ; indent code is for script editing + + +(defun proof-indent-indent () + "Determine indentation caused by syntax element at current point." + (cond + ((proof-looking-at-safe proof-indent-open-regexp) + proof-indent) + ((proof-looking-at-safe proof-indent-close-regexp) + (- proof-indent)) + (t 0))) + +(defun proof-indent-offset () + "Determine offset of syntax element at current point" + (cond + ((proof-looking-at-syntactic-context) + proof-indent) + ((proof-looking-at-safe proof-indent-inner-regexp) + proof-indent) + ((proof-looking-at-safe proof-indent-enclose-regexp) + proof-indent-enclose-offset) + ((proof-looking-at-safe proof-indent-open-regexp) + proof-indent-open-offset) + ((proof-looking-at-safe proof-indent-close-regexp) + proof-indent-close-offset) + ((proof-looking-at-safe proof-indent-any-regexp) 0) + ((proof-looking-at-safe "\\s-*$") 0) + (t proof-indent))) + +(defun proof-indent-inner-p () + "Check if current point is between actual indentation elements." + (or + (proof-looking-at-syntactic-context) + (proof-looking-at-safe proof-indent-inner-regexp) + (not + (or (proof-looking-at-safe proof-indent-any-regexp) + (proof-looking-at-safe "\\s-*$"))))) + +(defun proof-indent-goto-prev () ; Note: may change point, even in case of failure! + "Goto to previous syntax element for script indentation, ignoring string/comment contexts." + (and + (proof-re-search-backward proof-indent-any-regexp nil t) + (or (not (proof-looking-at-syntactic-context)) + (proof-indent-goto-prev)))) + +(defun proof-indent-calculate (indent inner) ; Note: may change point! + "Calculate proper indentation level at current point" + (let* + ((current (point)) + (found-prev (proof-indent-goto-prev))) + (if (not found-prev) (goto-char current)) ; recover position + (cond + ((and found-prev (or proof-indent-hang (= (current-indentation) (current-column)))) + (+ indent + (current-column) + (if (and inner (not (proof-indent-inner-p))) 0 (proof-indent-indent)) + (- (proof-indent-offset)))) + ((not found-prev) 0) ;FIXME mmw: improve this case!? + (t + (proof-indent-calculate + (+ indent (if inner 0 (proof-indent-indent))) inner))))) + + +;;;###autoload +(defun proof-indent-line () + "Indent current line of proof script, if indentation enabled." + (interactive) + (unless (not (proof-ass script-indent)) + (if (< (point) (proof-locked-end)) + (if (< (current-column) (current-indentation)) + (skip-chars-forward "\t ")) + (save-excursion + (indent-line-to + (max 0 (save-excursion + (back-to-indentation) + (proof-indent-calculate (proof-indent-offset) (proof-indent-inner-p)))))) + (if (< (current-column) (current-indentation)) + (back-to-indentation))))) + + + +(provide 'proof-indent) diff --git a/generic/proof-menu.el b/generic/proof-menu.el new file mode 100644 index 00000000..0970a393 --- /dev/null +++ b/generic/proof-menu.el @@ -0,0 +1,797 @@ +;; proof-menu.el Menus, keymaps, and misc commands for Proof General +;; +;; Copyright (C) 2000,2001 LFCS Edinburgh. +;; Authors: David Aspinall +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; + +(require 'proof-toolbar) ; needed for proof-toolbar-scripting-menu + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Miscellaneous commands +;;; + +(defvar proof-display-some-buffers-count 0) + +(defun proof-display-some-buffers () + "Display the reponse, goals, trace, or shell buffer, rotating. +A fixed number of repetitions of this command switches back to +the same buffer. +Also move point to the end of the response buffer if it's selected. +If in three window or multiple frame mode, display two buffers." + (interactive) + ;; The GUI-tessence here is to implement a humane toggle, which + ;; allows habituation. E.g. two taps of C-c C-l always + ;; shows the goals buffer, three the trace buffer, etc. + ;; (That behaviour makes less sense from the menu, though, + ;; where it seems more natural just to rotate from last + ;; position) + (cond + ((and (interactive-p) + (eq last-command 'proof-display-some-buffers)) + (incf proof-display-some-buffers-count)) + (t + (setq proof-display-some-buffers-count 0))) + (let* ((assocbufs (remove-if-not 'buffer-live-p + (list proof-response-buffer + proof-goals-buffer + proof-thms-buffer + proof-trace-buffer))) + ;proof-shell-buffer + (selectedbuf (nth (mod proof-display-some-buffers-count + (length assocbufs)) assocbufs))) + (cond + ((or proof-three-window-mode proof-multiple-frames-enable) + ;; Display two buffers: next in rotation and goals/response + ;; FIXME: this doesn't work as well as it might. + (proof-switch-to-buffer selectedbuf 'noselect) + (proof-switch-to-buffer (if (eq selectedbuf proof-goals-buffer) + proof-response-buffer + proof-goals-buffer) 'noselect)) + (selectedbuf + (proof-switch-to-buffer selectedbuf 'noselect))) + (if (eq selectedbuf proof-response-buffer) + (set-window-point (get-buffer-window proof-response-buffer) + (point-max))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Key bindings +;;; + +;;;###autoload +(defun proof-menu-define-keys (map) +;; M-a and M-e are usually {forward,backward}-sentence. +;; Some modes also override these with similar commands +(define-key map [(meta a)] 'proof-backward-command) +(define-key map [(meta e)] 'proof-forward-command) +(define-key map [(meta up)] 'proof-backward-command) +(define-key map [(meta down)] 'proof-forward-command) +(define-key map [(control meta a)] 'proof-goto-command-start) +(define-key map [(control meta e)] 'proof-goto-command-end) +(define-key map [(control c) (control a)] (proof-ass keymap)) +(define-key map [(control c) (control b)] 'proof-process-buffer) +;; C-c C-c is proof-interrupt-process in universal-keys +(define-key map [(control c) (control f)] 'proof-find-theorems) +(define-key map [(control c) (control h)] 'proof-help) +(define-key map [(control c) (control l)] 'proof-display-some-buffers) +(define-key map [(control c) (control n)] 'proof-assert-next-command-interactive) +(define-key map [(control c) (control p)] 'proof-prf) +(define-key map [(control c) (control r)] 'proof-retract-buffer) +(define-key map [(control c) (control s)] 'proof-toggle-active-scripting) +(define-key map [(control c) (control t)] 'proof-ctxt) +(define-key map [(control c) (control u)] 'proof-undo-last-successful-command) +;; C-c C-w is pg-response-clear-displays in universal-keys +(define-key map [(control c) (control z)] 'proof-frob-locked-end) +(define-key map [(control c) (control backspace)] 'proof-undo-and-delete-last-successful-command) +; C-c C-v is proof-minibuffer-cmd in universal-keys +(define-key map [(control c) (control ?.)] 'proof-goto-end-of-locked) +(define-key map [(control c) (control return)] 'proof-goto-point) +(define-key map [(control c) v] 'pg-toggle-visibility);; FIXME: FSF?? +(cond ((string-match "XEmacs" emacs-version) +(define-key map [(control button3)] 'proof-mouse-goto-point) +(define-key map [(control button1)] 'proof-mouse-track-insert)) ; no FSF + (t +(define-key map [(control mouse-3)] 'proof-mouse-goto-point))) + ; FSF +;; NB: next binding overwrites comint-find-source-code. +;; FIXME: not implemented yet +;; (define-key map [(meta p)] 'proof-previous-matching-command) +;; (define-key map [(meta n)] 'proof-next-matching-command) +;; Standard binding for completion +(define-key map [(control return)] 'proof-script-complete) +(define-key map [(control c) (control ?\;)] 'pg-insert-last-output-as-comment) +;; +;; Experimental: span moving functions +(if proof-experimental-features (progn + (define-key map [(control meta up)] 'pg-move-region-up) + (define-key map [(control meta down)] 'pg-move-region-down))) +;; Add the universal keys bound in all PG buffers. +;; C-c ` is next-error in universal-keys +(proof-define-keys map proof-universal-keys)) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Functions to define the menus +;;; + +;; The main Proof-General generic menu + +;;;###autoload +(defun proof-menu-define-main () + (easy-menu-define + proof-mode-menu + proof-mode-map + "The main Proof General menu" + proof-main-menu)) + +;; The proof assistant specific menu + +;;;###autoload +(defun proof-menu-define-specific () + (easy-menu-define + proof-assistant-menu + proof-mode-map + (concat "The menu for " proof-assistant) + (cons proof-assistant + (append + (proof-ass menu-entries) + '("----") + (or proof-menu-favourites + (proof-menu-define-favourites-menu)) + (or proof-menu-settings + (proof-menu-define-settings-menu)) + '("----") + (list + (vector + (concat "Start " proof-assistant) + 'proof-shell-start + ':active '(not (proof-shell-live-buffer))) + (vector + (concat "Exit " proof-assistant) + 'proof-shell-exit + ':active '(proof-shell-live-buffer))) + '("----") + (list + (cons "Help" + (append + `([,(concat proof-assistant " information") + '(proof-help) + ,menuvisiblep proof-info-command] + [,(concat proof-assistant " web page") + '(browse-url proof-assistant-home-page) + ,menuvisiblep proof-assistant-home-page]) + (proof-ass help-menu-entries)))))))) + +(defun proof-assistant-menu-update () + "Update proof assistant menu in scripting buffers." + (proof-map-buffers (proof-buffers-in-mode proof-mode-for-script) + (proof-menu-define-settings-menu) + (proof-menu-define-specific) + (easy-menu-remove proof-assistant-menu) + (easy-menu-add proof-assistant-menu proof-mode-map))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Contents of the menus +;;; + +(defvar proof-help-menu + '("Help" + ["PG Info" (info "ProofGeneral") t] + ["PG Homepage" (browse-url proof-general-home-page) t] + ["About PG" proof-splash-display-screen t] + ["Send Bug Report" proof-submit-bug-report t]) + "Proof General help menu.") + +(defvar proof-show-hide-menu + '(("Show all" + ["Proofs" (pg-show-all-portions "proof") t] + ["Comments" (pg-show-all-portions "comment") t]) + ("Hide all" + ["Proofs" (pg-show-all-portions "proof" 'hide) t] + ["Comments" (pg-show-all-portions "comment" 'hide) t])) + "Show/hide submenu.") + +(defvar proof-buffer-menu + (cons "Buffers" + '(["Active Scripting" + (proof-switch-to-buffer proof-script-buffer) + :active (buffer-live-p proof-script-buffer)] + ["Rotate Output Buffers" + proof-display-some-buffers + :active (buffer-live-p proof-goals-buffer)] + ;;["Goals" + ;; (proof-switch-to-buffer proof-goals-buffer t) + ;; :active (buffer-live-p proof-goals-buffer)] + ;;["Response" + ;; (proof-switch-to-buffer proof-response-buffer t) + ;; :active (buffer-live-p proof-response-buffer)] + ["Shell" + (proof-switch-to-buffer proof-shell-buffer) + :active (buffer-live-p proof-shell-buffer)] + ;; FIXME: this next test doesn't work since menus + ;; loaded before proof-shell-trace-output-regexp is + ;; set (in proof-shell hook). Should be better with + ;; simplified customization mechanism. + ;; ( if proof-shell-trace-output-regexp ... ) + ;;'(["Trace" + ;;(proof-switch-to-buffer proof-trace-buffer) + ;;:active (buffer-live-p proof-trace-buffer)]) + ["Clear Responses" + pg-response-clear-displays + :active (buffer-live-p proof-response-buffer)])) + "Proof General buffer menu.") + + +;; Make the togglers used in options menu below + +(proof-deftoggle proof-three-window-mode) +(proof-deftoggle proof-script-fly-past-comments) +(proof-deftoggle proof-delete-empty-windows) +(proof-deftoggle proof-shrink-windows-tofit) +(proof-deftoggle proof-multiple-frames-enable proof-multiple-frames-toggle) +(proof-deftoggle proof-output-fontify-enable proof-output-fontify-toggle) +(proof-deftoggle proof-disappearing-proofs) +(proof-deftoggle-fn (proof-ass-sym x-symbol-enable) 'proof-x-symbol-toggle) + + + +(defvar proof-quick-opts-menu + (cons + "Options" + `(["Electric Terminator" proof-electric-terminator-toggle + :style toggle + :selected proof-electric-terminator-enable] + ["Fly Past Comments" proof-script-fly-past-comments-toggle + ,menuvisiblep (not proof-script-use-old-parser) + :style toggle + :selected proof-script-fly-past-comments] + ["Disppearing Proofs" proof-disappearing-proofs-toggle + :style toggle + :selected proof-disappearing-proofs] + ["Output Highlighting" proof-output-fontify-toggle + :active t + :style toggle + :selected proof-output-fontify-enable] + ["X-Symbol" proof-x-symbol-toggle + :active (proof-x-symbol-support-maybe-available) + :style toggle + :selected (proof-ass x-symbol-enable)] + ["Toolbar" proof-toolbar-toggle + ;; should really be split into :active & GNU Emacs's :visible + :active (and (or (featurep 'toolbar) (featurep 'tool-bar)) + (boundp 'proof-buffer-type) + ;; only allow toggling of toolbar enable in one + ;; buffer to avoid strange effects because we + ;; only keep one flag. (Strange effects because + ;; we only turn it off in one buffer at a time) + (eq proof-buffer-type 'script)) + :style toggle + :selected proof-toolbar-enable] + ("Display" + ["Three Window Mode" proof-three-window-mode-toggle + :active (not proof-multiple-frames-enable) + :style toggle + :selected proof-three-window-mode] + ["Delete Empty Windows" proof-delete-empty-windows-toggle + :active (not proof-multiple-frames-enable) + :style toggle + :selected proof-delete-empty-windows] + ["Shrink to Fit" proof-shrink-windows-tofit-toggle + :active (not proof-multiple-frames-enable) + :style toggle + :selected proof-shrink-windows-tofit] + ["Multiple Frames" proof-multiple-frames-toggle + :active (display-graphic-p) + :style toggle + :selected proof-multiple-frames-enable]) + ("Follow Mode" + ["Follow Locked Region" + (customize-set-variable 'proof-follow-mode 'locked) + :style radio + :selected (eq proof-follow-mode 'locked)] + ["Keep Locked Region Displayed" + (customize-set-variable 'proof-follow-mode 'follow) + :style radio + :selected (eq proof-follow-mode 'follow)] + ["Never Move" + (customize-set-variable 'proof-follow-mode 'ignore) + :style radio + :selected (eq proof-follow-mode 'ignore)]) + "----" + ["Reset Options" (proof-quick-opts-reset) + (proof-quick-opts-changed-from-defaults-p)] + ["Save Options" (proof-quick-opts-save) + (proof-quick-opts-changed-from-saved-p)])) + "Proof General quick options.") + +(defun proof-quick-opts-vars () + "Return a list of the quick option variables." + (list + 'proof-electric-terminator-enable + 'proof-script-fly-past-comments + 'proof-disappearing-proofs + 'proof-output-fontify-enable + (proof-ass-sym x-symbol-enable) + 'proof-toolbar-enable + ;; Display sub-menu + 'proof-three-window-mode + 'proof-delete-empty-windows + 'proof-multiple-frames-enable + 'proof-shrink-windows-tofit + 'proof-multiple-frames-enable + ;; Follow mode sub-menu + 'proof-follow-mode)) + +(defun proof-quick-opts-changed-from-defaults-p () + ;; FIXME: would be nice to add. Custom support? + t) + +(defun proof-quick-opts-changed-from-saved-p () + ;; FIXME: would be nice to add. Custom support? + t) + +(defun proof-quick-opts-save () + "Save current values of PG Options menu items using custom." + (interactive) + (apply 'pg-custom-save-vars (proof-quick-opts-vars))) + +(defun proof-quick-opts-reset () + "Reset PG Options menu to default values, using custom." + (interactive) + (apply 'pg-custom-reset-vars (proof-quick-opts-vars))) + +(defconst proof-config-menu + (list "----" + ;; buffer menu might better belong in toolbar menu? + proof-buffer-menu + proof-quick-opts-menu) + "Proof General configuration menu.") + +(defconst proof-advanced-menu + (cons "Advanced..." + (append + `(["Function Menu" function-menu + ,menuvisiblep (fboundp 'function-menu)] + ["Complete Identifier" proof-script-complete t]) + (list "-----") + proof-show-hide-menu + (list "-----") + ;; NB: customize-menu-create was buggy in earlier + ;; Emacs 21.X; okay since 21.1.1 + (list (customize-menu-create 'proof-general)) + (list (customize-menu-create 'proof-general-internals + "Internals")))) + "Advanced sub-menu of script functions and customize.") + + +(defvar proof-menu + '(["Next Error" proof-next-error + :active pg-next-error-regexp] + ["Scripting Active" proof-toggle-active-scripting + :style toggle + :selected (eq proof-script-buffer (current-buffer))]) + "The Proof General generic menu for scripting buffers.") + + +(defvar proof-main-menu + (cons proof-general-name + (append + proof-toolbar-scripting-menu + proof-menu + proof-config-menu + (list proof-advanced-menu) + (list proof-help-menu))) + "PG main menu used in scripting buffers.") + +(defvar proof-aux-menu + (cons proof-general-name + (append + proof-toolbar-scripting-menu + proof-config-menu + (list proof-help-menu))) + "PG auxiliary menu used in non-scripting buffers.") + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Favourites mechanism for prover-specific menu +;;; + +(defvar proof-menu-favourites nil + "The Proof General favourites menu for the current proof assistant.") + +(defun proof-menu-define-favourites-menu () + "Return menu generated from `PA-favourites'." + (let ((favs (reverse (proof-ass favourites))) ents) + (while favs + (setq ents (cons (apply 'proof-def-favourite (car favs)) ents)) + (setq favs (cdr favs))) + (setq proof-menu-favourites + (list + (cons "Favourites" + (append ents + ;; (list "----") doesn't work for adding before + '(["Add Favourite" + (call-interactively 'proof-add-favourite) t] + ["Delete Favourite" + (call-interactively 'proof-del-favourite) t] + ["Save Favourites" + (proof-save-favourites) t]))))))) + +;;; Define stuff from favourites + +;;;###autoload +(defmacro proof-defshortcut (fn string &optional key) + "Define shortcut function FN to insert STRING, optional keydef KEY. +This is intended for defining proof assistant specific functions. +STRING is inserted using `proof-insert', which see. +KEY is added onto proof-assistant map." + (if key + (eval ;; eval-after-load "proof" ? + `(define-key (proof-ass keymap) (quote ,key) (quote ,fn)))) + `(defun ,fn () + ,(concat "Shortcut command to insert " string " into the current buffer.") + (interactive) + (proof-insert ,string))) + +;;;###autoload +(defmacro proof-definvisible (fn string &optional key) + "Define function FN to send STRING to proof assistant, optional keydef KEY. +This is intended for defining proof assistant specific functions. +STRING is sent using proof-shell-invisible-command, which see. +KEY is added onto proof-assistant map." + (if key + (eval ;; eval-after-load "proof" ? + `(define-key (proof-ass keymap) (quote ,key) (quote ,fn)))) + `(defun ,fn () + ,(concat "Command to send " string " to the proof assistant.") + (interactive) + (proof-shell-invisible-command ,string))) + +(defun proof-def-favourite (command inscript menuname &optional key new) + "Define and a \"favourite\" proof assisant function. +See doc of `proof-add-favourite' for first four arguments. +Extra NEW flag means that this should be a new favourite, so check +that function defined is not already bound. +This function defines a function and returns a menu entry +suitable for adding to the proof assistant menu." + (let* ((menunames (split-string (downcase menuname))) + (menuname-sym (proof-sym (proof-splice-separator "-" menunames))) + (menu-fn menuname-sym) (i 1)) + (while (and new (fboundp menu-fn)) + (setq menu-fn (intern (concat (symbol-name menuname-sym) + "-" (int-to-string i)))) + (incf i)) + (if inscript + (eval `(proof-defshortcut ,menu-fn ,command ,key)) + (eval `(proof-definvisible ,menu-fn ,command ,key))) + ;; Return menu entry + (vector menuname menu-fn t))) + + +;;; Code for adding "favourites" to the proof-assistant specific menu + +(defvar proof-make-favourite-cmd-history nil + "History for proof-make-favourite.") + +(defvar proof-make-favourite-menu-history nil + "History for proof-make-favourite.") + +(defun proof-save-favourites () + "Save favourites in customization settings." + (interactive) + (pg-custom-save-vars (proof-ass-sym favourites))) + +(defun proof-del-favourite (menuname) + "Delete \"favourite\" command recorded at MENUNAME." + (interactive + (list + (completing-read "Menu item to delete: " + (mapcar 'cddr (proof-ass favourites)) + nil t))) + (let* + ((favs (proof-ass favourites)) + (rmfavs (remove-if + (lambda (f) (string-equal menuname (caddr f))) + favs))) + (unless (equal favs rmfavs) + (easy-menu-remove-item proof-assistant-menu + '("Favourites") menuname) + (customize-set-variable (proof-ass-sym favourites) rmfavs)))) + +(defun proof-read-favourite () + (let* + ((guess (buffer-substring (save-excursion + (beginning-of-line-text) + (point)) (point))) + (cmd (read-string + (concat "Command to send to " proof-assistant ": ") + guess + proof-make-favourite-cmd-history)) + (ins (y-or-n-p "Should command be recorded in script? ")) + (men (read-string + "Name of command on menu: " + cmd + proof-make-favourite-menu-history)) + (key (if (y-or-n-p "Set a keybinding for this command? : ") + ;; FIXME: better validation here would be to check + ;; this is a new binding, or remove old binding below. + (events-to-keys + (read-key-sequence + "Type the key to use (binding will be C-c C-a <key>): " + nil t))))) + ;; result + (list cmd ins men key))) + + +(defun proof-add-favourite (command inscript menuname &optional key) + "Define and add a \"favourite\" proof-assisant function to the menu bar. +The favourite function will issue COMMAND to the proof assistant. +COMMAND is inserted into script (not sent immediately) if INSCRIPT non-nil. +MENUNAME is the name of the function for the menu. +KEY is the optional key binding." + (interactive (proof-read-favourite)) + (let* + ((menu-entry (proof-def-favourite command inscript menuname key t)) + (favs (proof-ass favourites)) + (rmfavs (remove-if + (lambda (f) (string-equal menuname (caddr f))) + favs)) + (newfavs (append + rmfavs + (list (list command inscript menuname key))))) + ;; If def succeeds, add to customize var + (customize-set-variable (proof-ass-sym favourites) newfavs) + (easy-menu-add-item proof-assistant-menu + '("Favourites") menu-entry "Add Favourite"))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Proof assistant settings mechanism. +;;; + +(defvar proof-assistant-settings nil + "A list of default values kept in Proof General for current proof assistant. +A list of lists (SYMBOL SETTING TYPE) where SETTING is a string value +to send to the proof assistant using the value of SYMBOL and +and the function `proof-assistant-format'. The TYPE item determines +the form of the menu entry for the setting.") + +(defvar proof-menu-settings nil + "Settings submenu for Proof General.") + +(defun proof-menu-define-settings-menu () + "Return menu generated from `proof-assistant-settings', update `proof-menu-settings'." + (if proof-assistant-settings + (let ((setgs proof-assistant-settings) + (save (list "----" + ["Reset Settings" (proof-settings-reset) + (proof-settings-changed-from-defaults-p)] + ["Save Settings" (proof-settings-save) + (proof-settings-changed-from-saved-p)])) + ents) + (while setgs + (setq ents (cons + (apply 'proof-menu-entry-for-setting (car setgs)) ents)) + (setq setgs (cdr setgs))) + (setq proof-menu-settings + (list (cons "Settings" + (nconc ents save))))))) + +(defun proof-menu-entry-name (symbol) + "Return a nice menu entry name for SYMBOL." + (upcase-initials + (replace-in-string (symbol-name symbol) "-" " "))) + +(defun proof-menu-entry-for-setting (symbol setting type) + (let ((entry-name (proof-menu-entry-name symbol)) + (pasym (proof-ass-symv symbol))) + (cond + ((eq type 'boolean) + (vector entry-name + (proof-deftoggle-fn pasym) + :style 'toggle + :selected pasym)) + ((eq type 'integer) + (vector entry-name + (proof-defintset-fn pasym) + t)) + ((eq type 'string) + (vector entry-name + (proof-defstringset-fn pasym) + t))))) + +(defun proof-settings-vars () + "Return a list of proof assistant setting variables." + (mapcar (lambda (setting) (proof-ass-symv (car setting))) + proof-assistant-settings)) + +(defun proof-settings-changed-from-defaults-p () + ;; FIXME: would be nice to add. Custom support? + t) + +(defun proof-settings-changed-from-saved-p () + ;; FIXME: would be nice to add. Custom support? + t) + +(defun proof-settings-save () + "Save current values of proof assistant settings using Custom." + (interactive) + (apply 'pg-custom-save-vars (proof-settings-vars))) + +(defun proof-settings-reset () + "Reset proof assistant settings to their default values." + (interactive) + (apply 'pg-custom-reset-vars (proof-settings-vars))) + + +;;; autoload for compiled version: used in macro proof-defpacustom +;;;###autoload +(defun proof-defpacustom-fn (name val args) + "As for macro `defpacustom' but evaluating arguments." + (let (newargs setting evalform type) + (while args + (cond + ((eq (car args) :setting) + (setq setting (cadr args)) + (setq args (cdr args))) + ((eq (car args) :eval) + (setq evalform (cadr args)) + (setq args (cdr args))) + ((eq (car args) :type) + (setq type (cadr args)) + (setq newargs (cons (car args) newargs))) + (t + (setq newargs (cons (car args) newargs)))) + (setq args (cdr args))) + (setq newargs (reverse newargs)) + (unless (or setting evalform) + (error "defpacustom: missing :setting or :eval keyword")) + (unless (and type + (or (eq (eval type) 'boolean) + (eq (eval type) 'integer) + (eq (eval type) 'string))) + (error "defpacustom: missing :type keyword or wrong :type value")) + ;; Debug message in case a defpacustom is repeated. + ;; NB: this *may* happen dynamically, but shouldn't: if the + ;; interface queries the prover for the settings it supports, + ;; then the internal list should be cleared first. + ;; FIXME: for now, we support redefinitions, by calling + ;; pg-custom-undeclare-variable. + (if (assoc name proof-assistant-settings) + (progn + (proof-debug "defpacustom: Proof assistanting setting %s re-defined!" + name) + (undefpgcustom name))) + ;; Could consider moving the bulk of the remainder of this + ;; function to a function proof-assistant-setup-settings which + ;; defines the custom vals *and* menu entries. This would allow + ;; proof assistant customization to manipulate + ;; proof-assistant-settings directly rather than forcing use of + ;; defpacustom. (Probably stay as we are: more abstract) + (eval + `(defpgcustom ,name ,val + ,@newargs + :set 'proof-set-value + :group 'proof-assistant-setting)) + (if evalform + (eval + `(defpgfun ,name () + ,evalform)) + (eval + `(defpgfun ,name () + (proof-assistant-invisible-command-ifposs + (proof-assistant-settings-cmd (quote ,name)))))) + (setq proof-assistant-settings + (cons (list name setting (eval type)) + (remassoc name proof-assistant-settings))))) + +;;;###autoload +(defmacro defpacustom (name val &rest args) + "Define a setting NAME for the current proof assitant, default VAL. +NAME can correspond to some internal setting, flag, etc, for the +proof assistant, in which case a :setting and :type value should be provided. +The :type of NAME should be one of 'integer, 'boolean, 'string. +The customization variable is automatically in group `proof-assistant-setting. +The function `proof-assistant-format' is used to format VAL. +If NAME corresponds instead to a PG internal setting, then a form :eval to +evaluate can be provided instead." + `(proof-defpacustom-fn (quote ,name) (quote ,val) (quote ,args))) + +(defun proof-assistant-invisible-command-ifposs (cmd) + "Send CMD as an \"invisible command\" if the proof process is available." + ;; FIXME: better would be to queue the command, or even interrupt a + ;; queue in progress. Also must send current settings at start of + ;; session somehow. (This might happen automatically if a queue of + ;; deffered commands is set, since defcustom calls proof-set-value + ;; even to set the default/initial value?) + (if (proof-shell-available-p) + (progn + (proof-shell-invisible-command cmd t) + ;; refresh display, + ;; FIXME: should only do if goals display is active, + ;; messy otherwise. + ;; (we need a new flag for "active goals display"). + (if proof-showproof-command + (proof-shell-invisible-command proof-showproof-command)) + ;; Could also repeat last command if non-state destroying. + ))) + + +(defun proof-assistant-settings-cmd (&optional setting) + "Return string for making setting vals kept in Proof General customizations. +If SETTING is non-nil, return a string for just that setting. +Otherwise return a string for configuring all settings. + +If `proof-assistants-settings' is nil and PGIP is supported, then +first we query settings information from prover." + ;; This is a slightly ugly way: this function may be called to + ;; calculate a string for setting preferences, and is a possible + ;; setting for proof-shell-init-cmd. But it needs to be evaluated + ;; each time (in case preferences change), and may trigger a nested + ;; call to proof-shell-invisible-cmd to send askprefs message. + (if (and (not proof-assistant-settings) + proof-shell-issue-pgip-cmd) + (pg-pgip-askprefs)) + (let + ((evalifneeded (lambda (expr) + (if (and (cadr expr) ;; setting has PA string? + (or (not setting) + (eq setting (car expr)))) + (proof-assistant-format + (cadr expr) + (eval (proof-ass-symv (car expr)))))))) + (apply 'concat (mapcar evalifneeded + proof-assistant-settings)))) + +(defun proof-assistant-format (string curvalue) + "Replace a format characters %b %i %s in STRING by formatted CURVALUE. +Formatting suitable for current proof assistant, controlled by +`proof-assistant-format-table' which see. +Finally, apply `proof-assistant-setting-format' if non-nil. +As a special case for boolean settings: the setting STRING +can be a cons cell of two strings, the first one for true (non-nil +value) and the second for false." + (let ((setting + (if (consp string) + (if curvalue (car string) (cdr string)) + ;; Otherwise must use % format characters + (proof-format proof-assistant-format-table string)))) + (if proof-assistant-setting-format + (funcall proof-assistant-setting-format setting) + setting))) + +(defvar proof-assistant-format-table + (list + (cons "%b" '(proof-assistant-format-bool curvalue)) + (cons "%i" '(proof-assistant-format-int curvalue)) + (cons "%s" '(proof-assistant-format-string curvalue))) + "Table to use with `proof-format' for formatting CURVALUE for assistant. +NB: variable curvalue is dynamically scoped (used in proof-assistant-format).") + +(defun proof-assistant-format-bool (value) + (if value proof-assistant-true-value proof-assistant-false-value)) + +(defun proof-assistant-format-int (value) + (funcall proof-assistant-format-int-fn value)) + +(defun proof-assistant-format-string (value) + (funcall proof-assistant-format-string-fn value)) + + + + +(provide 'proof-menu) +;; proof-menu.el ends here. diff --git a/generic/proof-script.el b/generic/proof-script.el new file mode 100644 index 00000000..8c5421c2 --- /dev/null +++ b/generic/proof-script.el @@ -0,0 +1,2805 @@ +;; proof-script.el Major mode for proof assistant script files. +;; +;; Copyright (C) 1994-2001 LFCS Edinburgh. +;; Authors: David Aspinall, Yves Bertot, Healfdene Goguen, +;; Thomas Kleymann and Dilip Sequeira +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; + +(require 'proof) ; loader +(require 'proof-syntax) ; utils for manipulating syntax +(require 'span) ; abstraction of overlays/extents +(require 'pg-user) ; user-level commands +(require 'proof-menu) ; menus for script mode + + + +;; Nuke some byte-compiler warnings +;; NB: eval-when (compile) is different to eval-when-compile!! +(eval-when (compile) + (proof-try-require 'func-menu) + (require 'comint)) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; PRIVATE VARIABLES +;; +;; Local variables used by proof-script-mode +;; + +;; Scripting variables + +(defvar proof-last-theorem-dependencies nil + "Contains the dependencies of the last theorem. A list of strings. +Set in `proof-shell-process-urgent-message'.") + +(defvar proof-nesting-depth 0 + "Current depth of a nested proof. +Zero means outside a proof, 1 means inside a top-level proof, etc. + +This variable is maintained in proof-done-advancing; it is zeroed +in proof-shell-clear-state.") + +(defvar proof-element-counters nil + "Table of (name . count) pairs, counting elements in scripting buffer.") + + +;; Buffer-local variables + +(deflocal proof-active-buffer-fake-minor-mode nil + "An indication in the modeline that this is the *active* script buffer") + +(deflocal proof-script-buffer-file-name nil + ;; NB: if buffer-file-name is nil for some other reason, this may break. + "A copied value of buffer-file-name to cope with `find-alternative-file'. +The `find-alternative-file' function has a nasty habit of setting the +buffer file name to nil before running kill buffer, which breaks PG's +kill buffer hook. This variable is used when buffer-file-name is nil.") + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Counting and naming proof elements +;; + +(defun proof-next-element-count (idiom) + "Return count for next element of type IDIOM. +This uses and updates `proof-element-counters'." + (let ((next (1+ (or (cdr-safe (assq idiom proof-element-counters)) 0)))) + (setq proof-element-counters + (cons (cons idiom next) + (remassq idiom proof-element-counters))) + next)) + +(defun proof-element-id (idiom number) + "Return a string identifier composed from symbol IDIOM and NUMBER." + (concat (symbol-name idiom) "-" (int-to-string number))) + +(defun proof-next-element-id (idiom) + (proof-element-id idiom (proof-next-element-count idiom))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Configuration of function-menu (aka "fume") +;; +;; FIXME: we would like this code only enabled if the user loads +;; func-menu into Emacs. +;; + +(deflocal proof-script-last-entity nil + "Record of last entity found. +A hack for entities that are named in two places, so that `find-next-entity' +doesn't return the same values twice.") + +;; FIXME mmw: maybe handle comments/strings by using +;; proof-looking-at-syntactic-context +(defun proof-script-find-next-entity (buffer) + "Find the next entity for function menu in a proof script. +A value for `fume-find-function-name-method-alist' for proof scripts. +Uses `fume-function-name-regexp', which is initialised from +`proof-script-next-entity-regexps', which see." + ;; Hopefully this function is fast enough. + (set-buffer buffer) + ;; could as well use next-entity-regexps directly since this is + ;; not really meant to be used as a general function. + (let ((anyentity (car fume-function-name-regexp))) + (if (proof-re-search-forward anyentity nil t) + ;; We've found some interesting entity, but have to find out + ;; which one, and where it begins. + (let ((entity (buffer-substring (match-beginning 0) (match-end 0))) + (start (match-beginning 0)) + (discriminators (cdr fume-function-name-regexp)) + (p (point)) + disc res) + (while (and (not res) (setq disc (car-safe discriminators))) + (if (proof-string-match (car disc) entity) + (let* + ((items (nth 1 disc)) + (items (if (numberp items) (list items) items)) + (name "")) + (dolist (item items) + (setq name + (concat name + (substring entity + (match-beginning item) + (match-end item)) + " "))) + (cond + ((eq (nth 2 disc) 'backward) + (setq start + (or (proof-re-search-backward (nth 3 disc) nil t) + start)) + (goto-char p)) + ((eq (nth 2 disc) 'forward) + (proof-re-search-forward (nth 3 disc)))) + (setq res (cons name start))) + (setq discriminators (cdr discriminators)))) + res)))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Basic functions for handling the locked and queue regions +;; +;; -------------------------------------------------------------- +;; +;; Notes on regions in the scripting buffer. (da) +;; +;; The locked region is covered by a collection of non-overlaping +;; spans (our abstraction of extents/overlays). +;; +;; For an unfinished proof, there is one extent for each command +;; or comment outside a command. For a finished proof, there +;; is one extent for the whole proof. +;; +;; Each command span has a 'type property, one of: +;; +;; 'goalsave A goal..savegoal region in the buffer, a completed proof. +;; 'vanilla Initialised in proof-semis-to-vanillas, for +;; 'comment A comment outside a command. +;; 'proverproc A region closed by the prover, processed outwith PG +;; 'pbp A PBP command inserted automatically into the script +;; +;; All spans except those of type 'comment have a 'cmd property, +;; which is set to a string of its command. This is the +;; text in the buffer stripped of leading whitespace and any comments. +;; + +;; ** Variables + +(deflocal proof-locked-span nil + "The locked span of the buffer. +Each script buffer has its own locked span, which may be detached +from the buffer. +Proof General allows buffers in other modes also to be locked; +these also have a non-nil value for this variable.") + +(deflocal proof-queue-span nil + "The queue span of the buffer. May be detached if inactive or empty. +Each script buffer has its own queue span, although only the active +scripting buffer may have an active queue span.") +;; da: reason for buffer local queue span is because initialisation +;; in proof-init-segmentation can happen when a file is visited. +;; So nasty things might happen if a locked file is visited whilst +;; another buffer has a non-empty queue region being processed. + + +;; ** Getters and setters + +(defun proof-span-read-only (span) + "Make span be read-only, if proof-strict-read-only is non-nil. +Otherwise make span give a warning message on edits." + ;; Note: perhaps the queue region should always be locked strictly. + (if proof-strict-read-only + (span-read-only span) + (span-write-warning span))) + +;; not implemented yet: presently must toggle via restarting scripting +;; (defun proof-toggle-strict-read-only () +;; "Toggle proof-strict-read-only, changing current spans." +;; (interactive) +;; map-spans blah +;; ) + +(defsubst proof-set-queue-endpoints (start end) + "Set the queue span to be START, END." + (set-span-endpoints proof-queue-span start end)) + +(defsubst proof-set-locked-endpoints (start end) + "Set the locked span to be START, END." + (set-span-endpoints proof-locked-span start end)) + +(defsubst proof-detach-queue () + "Remove the span for the queue region." + (and proof-queue-span (detach-span proof-queue-span))) + +(defsubst proof-detach-locked () + "Remove the span for the locked region." + (and proof-locked-span (detach-span proof-locked-span))) + +(defsubst proof-set-queue-start (start) + "Set the queue span to begin at START." + (set-span-start proof-queue-span start)) + +(defsubst proof-set-locked-end (end) + "Set the end of the locked region to be END. +If END is at or before (point-min), remove the locked region. +Otherwise set the locked region to be from (point-min) to END." + ;; FIXME: is it really needed to detach the span here? + (if (>= (point-min) end) + (proof-detach-locked) + (set-span-endpoints + proof-locked-span + (point-min) + (min (point-max) end) ;; safety: sometimes called with end>point-max(?) + ))) + +;; Reimplemented this to mirror above because of remaining +;; span problen +(defsubst proof-set-queue-end (end) + "Set the queue span to end at END." + (if (or (>= (point-min) end) + (<= end (span-start proof-queue-span))) + (proof-detach-queue) + (set-span-end proof-queue-span end))) + + +;; ** Initialise spans for a buffer + +(defun proof-init-segmentation () + "Initialise the queue and locked spans in a proof script buffer. +Allocate spans if need be. The spans are detached from the +buffer, so the regions are made empty by this function. +Also clear list of script portions." + ;; Initialise queue span, remove it from buffer. + (unless proof-queue-span + (setq proof-queue-span (make-span 1 1)) + ;; FIXME: span-raise is an GNU hack to make locked span appear. + ;; overlays still don't work as well as they did/should pre 99. + (span-raise proof-queue-span)) + (set-span-property proof-queue-span 'start-closed t) + (set-span-property proof-queue-span 'end-open t) + (proof-span-read-only proof-queue-span) + (set-span-property proof-queue-span 'face 'proof-queue-face) + (detach-span proof-queue-span) + ;; Initialise locked span, remove it from buffer + (unless proof-locked-span + (setq proof-locked-span (make-span 1 1)) + (span-raise proof-locked-span)) + (set-span-property proof-locked-span 'start-closed t) + (set-span-property proof-locked-span 'end-open t) + (proof-span-read-only proof-locked-span) + (set-span-property proof-locked-span 'face 'proof-locked-face) + (detach-span proof-locked-span) + (setq proof-last-theorem-dependencies nil) + (setq proof-element-counters nil) + (pg-clear-script-portions)) + + +;; ** Restarting and clearing spans + +(defun proof-restart-buffers (buffers) + "Remove all extents in BUFFERS and maybe reset `proof-script-buffer'. +No effect on a buffer which is nil or killed. If one of the buffers +is the current scripting buffer, then proof-script-buffer +will deactivated." + (mapcar + (lambda (buffer) + (save-excursion + (if (buffer-live-p buffer) + (with-current-buffer buffer + (if proof-active-buffer-fake-minor-mode + (setq proof-active-buffer-fake-minor-mode nil)) + (delete-spans (point-min) (point-max) 'type) ;; remove top-level spans + (delete-spans (point-min) (point-max) 'idiom) ;; and embedded spans + (setq pg-script-portions nil) ;; also the record of them + (proof-detach-queue) ;; remove queue and locked + (proof-detach-locked) + (proof-init-segmentation))) + (if (eq buffer proof-script-buffer) + (setq proof-script-buffer nil)))) + buffers)) + +(defun proof-script-buffers-with-spans () + "Return a list of all buffers with spans. +This is calculated by finding all the buffers with a non-nil +value of proof-locked span." + (let ((bufs-left (buffer-list)) + bufs-got) + (dolist (buf bufs-left bufs-got) + (if (with-current-buffer buf proof-locked-span) + (setq bufs-got (cons buf bufs-got)))))) + +(defun proof-script-remove-all-spans-and-deactivate () + "Remove all spans from scripting buffers via proof-restart-buffers." + (proof-restart-buffers (proof-script-buffers-with-spans))) + +(defun proof-script-clear-queue-spans () + "If there is an active scripting buffer, remove the queue span from it. +This is a subroutine used in proof-shell-handle-{error,interrupt}." + (if proof-script-buffer + (with-current-buffer proof-script-buffer + (proof-detach-queue) + ;; FIXME da: point-max seems a bit excessive here, + ;; proof-queue-or-locked-end should be enough. + (delete-spans (proof-locked-end) (point-max) 'type)))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Buffer position functions +;; + +(defun proof-unprocessed-begin () + "Return end of locked region in current buffer or (point-min) otherwise. +The position is actually one beyond the last locked character." + (or + (and proof-locked-span + (span-end proof-locked-span)) + (point-min))) + +(defun proof-script-end () + "Return the character beyond the last non-whitespace character. +This is the same position proof-locked-end ends up at when asserting +the script. Works for any kind of buffer." + (save-excursion + (goto-char (point-max)) + (skip-chars-backward " \t\n") + (point))) + +(defun proof-queue-or-locked-end () + "Return the end of the queue region, or locked region, or (point-min). +This position should be the first writable position in the buffer. +An appropriate point to move point to (or make sure is displayed) +when a queue of commands is being processed." + (or + ;; span-end returns nil if span is detatched + (and proof-queue-span (span-end proof-queue-span)) + (and proof-locked-span (span-end proof-locked-span)) + (point-min))) + +;; FIXME: get rid of/rework this function. Some places expect this to +;; return nil if locked region is empty. Moreover, it confusingly +;; returns the point past the end of the locked region. +(defun proof-locked-end () + "Return end of the locked region of the current buffer. +Only call this from a scripting buffer." + (proof-unprocessed-begin)) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Predicates for locked region. +;; +;; These work on any buffer, so that non-script buffers can be locked +;; (as processed files) too. +;; + +(defun proof-locked-region-full-p () + "Non-nil if the locked region covers all the buffer's non-whitespace. +Works on any buffer." + (save-excursion + (goto-char (point-max)) + (skip-chars-backward " \t\n") + (>= (proof-unprocessed-begin) (point)))) + +(defun proof-locked-region-empty-p () + "Non-nil if the locked region is empty. Works on any buffer." + (eq (proof-unprocessed-begin) (point-min))) + +(defun proof-only-whitespace-to-locked-region-p () + "Non-nil if only whitespace separates char after point from end of locked region. +Point should be after the locked region. +NB: If nil, point is left at first non-whitespace character found. +If non-nil, point is left where it was." + ;; NB: this function doesn't quite do what you'd expect, but fixing it + ;; breaks proof-assert-until-point and electric-terminator which + ;; rely on the side effect. So careful! + ;; (unless (eobp) + ;; (forward-char)) + ;; (save-excursion -- no, side effect is expected! + (not (proof-re-search-backward "\\S-" (proof-unprocessed-begin) t))) + +(defun proof-in-locked-region-p () + "Non-nil if point is in locked region. Assumes proof script buffer current." + (< (point) (proof-unprocessed-begin))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Misc movement functions +;; + +(defun proof-goto-end-of-locked (&optional switch) + "Jump to the end of the locked region, maybe switching to script buffer. +If interactive or SWITCH is non-nil, switch to script buffer first." + (interactive) + (proof-with-script-buffer + (if (and (not (get-buffer-window proof-script-buffer)) + (or switch (interactive-p))) + (switch-to-buffer proof-script-buffer) + (goto-char (proof-unprocessed-begin))))) + +;; Careful: movement can happen when the user is typing, not very nice! +(defun proof-goto-end-of-locked-if-pos-not-visible-in-window () + "If the end of the locked region is not visible, jump to the end of it. +A possible hook function for proof-shell-handle-error-or-interrupt-hook. +Does nothing if there is no active scripting buffer, or if +`proof-follow-mode' is set to 'ignore." + (interactive) + (if (and proof-script-buffer + (not (eq proof-follow-mode 'ignore))) + (let ((pos (with-current-buffer proof-script-buffer + (proof-locked-end))) + (win (get-buffer-window proof-script-buffer t))) + (unless (and win (pos-visible-in-window-p pos)) + (proof-goto-end-of-locked t))))) + +;; Simplified version of above for toolbar follow mode -- which wouldn't +;; work with abouve because of proof-shell-handle-error-or-interrupt-hook[?] +(defun proof-goto-end-of-queue-or-locked-if-not-visible () + "Jump to the end of the queue region or locked region if it isn't visible. +Assumes script buffer is current" + (unless (pos-visible-in-window-p + (proof-queue-or-locked-end) + (get-buffer-window (current-buffer) t)) + (goto-char (proof-queue-or-locked-end)))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Names of proofs (and other elements) in a script +;; +;; Each kind of part ("idiom") in a proof script has its own name space. +;; Visibility within a script is then handled with buffer-invisibility-spec +;; controlling appearance of each idiom. +;; + +(defvar pg-idioms '(proof) + "Vector of script element kinds PG is aware of for this prover.") + +(defvar pg-visibility-specs nil + "Cache of visibility spec symbols used by PG.") + + +(deflocal pg-script-portions nil + "Table of lists of symbols naming script portions which have been processed so far.") + +(defun pg-clear-script-portions () + "Clear record of script portion names and types from internal list. +Also clear all visibility specifications." + (setq pg-script-portions nil) + (setq buffer-invisibility-spec nil)) + +(defun pg-add-script-element (elt) + (add-to-list pg-script-portions elt)) + +(defun pg-remove-script-element (ns id) + (let* ((elts (cdr-safe (assq ns pg-script-portions))) + (newelts (remq id elts))) + (setq pg-script-portions + (if newelts + (cons (cons ns newelts) (remassq ns pg-script-portions)) + (remassq ns pg-script-portions))))) + +(defsubst pg-visname (namespace id) + "Return a unique symbol made from strings NAMESPACE and unique ID." + (intern (concat namespace ":" id))) + +(defun pg-add-element (idiom id span &optional name) + "Add element of type IDIOM with identifier ID, referred to by SPAN. +This records the element in `pg-script-portions' and sets span +properties accordingly. +IDIOM, ID, and optional NAME are all strings. +Identifiers must be unique for a given idiom; the optional NAME +will be recorded as a textual name used instead of ID for users; +NAME does not need to be unique." + (let* ((idiomsym (intern idiom)) + (idsym (intern id)) + (name (or name id)) + (visname (pg-visname idiom id)) + (delfn `(lambda () (pg-remove-element (quote ,idiomsym) (quote ,idsym)))) + (elts (cdr-safe (assq idiomsym pg-script-portions)))) + (if elts + (if (memq id elts) + (proof-debug "Element named " name " (type " idiom ") already in buffer.") + (nconc elts (list idsym))) + (setq pg-script-portions (cons (cons idiomsym (list idsym)) + pg-script-portions))) + ;; Idiom and ID are stored in the span as symbols; name as a string. + (set-span-property span 'idiom idiomsym) + (set-span-property span 'id idsym) + (set-span-property span 'name name) + (set-span-property span 'span-delete-action delfn) + (set-span-property span 'invisible visname) + ;; Bad behaviour if span gets copied: unique ID shouldn't be duplicated. + (set-span-property span 'duplicable nil) ;; NB: not supported in Emacs + ;; Nice behaviour in with isearch: open invisible regions temporarily. + (set-span-property span 'isearch-open-invisible + 'pg-open-invisible-span) + (set-span-property span 'isearch-open-invisible-temporary + 'pg-open-invisible-span))) + +(defun pg-open-invisible-span (span &optional invisible) + "Function for `isearch-open-invisible' property." + (let ((idiom (span-property span 'idiom)) + (id (span-property span 'id))) + (and idiom id + (if invisible + (pg-make-element-invisible + (symbol-name idiom) id) + (pg-make-element-visible + (symbol-name idiom) (symbol-name id)))))) + +(defun pg-remove-element (ns idsym) + (pg-remove-script-element ns idsym) + ;; We could leave the visibility note, but that may + ;; be counterintuitive, so lets remove it. + (pg-make-element-visible (symbol-name ns) (symbol-name idsym)) + (pg-redisplay-for-gnuemacs)) + +(defun pg-make-element-invisible (idiom id) + "Make element ID of type IDIOM invisible, with ellipsis." + (add-to-list 'buffer-invisibility-spec + (cons (pg-visname idiom id) t))) + +(defun pg-make-element-visible (idiom id) + "Make element ID of type IDIOM visible." + (setq buffer-invisibility-spec + (remassq (pg-visname idiom id) buffer-invisibility-spec))) + +(defun pg-toggle-element-visibility (idiom id) + "Toggle visibility of script element of type IDIOM, named ID." + (if (and (listp buffer-invisibility-spec) + (assq (pg-visname idiom id) buffer-invisibility-spec)) + (pg-make-element-visible idiom id) + (pg-make-element-invisible idiom id)) + (pg-redisplay-for-gnuemacs)) + +(defun pg-redisplay-for-gnuemacs () + "GNU Emacs requires redisplay for changes in buffer-invisibility-spec." + (if proof-running-on-Emacs21 + ;; GNU Emacs requires redisplay here to see result + ;; (sit-for 0) not enough + (redraw-frame (selected-frame)))) + +(defun pg-show-all-portions (idiom &optional hide) + "Show or hide all portions of kind IDIOM" + (interactive + (list + (completing-read + (concat "Make " (if current-prefix-arg "in" "") "visible all regions of: ") + (apply 'vector pg-idioms) nil t) + current-prefix-arg)) + (let ((elts (cdr-safe (assq (intern idiom) pg-script-portions))) + (alterfn (if hide + (lambda (arg) (pg-make-element-invisible idiom + (symbol-name arg))) + (lambda (arg) (pg-make-element-visible idiom + (symbol-name arg)))))) + (mapcar alterfn elts)) + (pg-redisplay-for-gnuemacs)) + +;; Next two could be in pg-user.el. No key-bindings for these. +(defun pg-show-all-proofs () + "Display all completed proofs in the buffer." + (interactive) + (pg-show-all-portions "proof")) + +(defun pg-hide-all-proofs () + "Hide all completed proofs in the buffer." + (interactive) + (pg-show-all-portions "proof" 'hide)) + +(defun pg-add-proof-element (name span controlspan) + "Add a nested span proof element." + (let ((proofid (proof-next-element-id 'proof))) + (pg-add-element "proof" proofid span name) + ;; Set id in controlspan + (set-span-property controlspan 'id (intern proofid)) + ;; Make a navigable link between the two spans. + (set-span-property span 'controlspan controlspan) + (set-span-property controlspan 'children + (cons span (span-property controlspan 'children))) + (pg-set-span-helphighlights span 'nohighlight) + (if proof-disappearing-proofs + (pg-make-element-invisible "proof" proofid)))) + +(defun pg-span-name (span) + "Return a user-level name for SPAN." + (let ((type (span-property span 'type)) + (idiom (span-property span 'idiom)) + (name (span-property span 'name))) + (cond + (idiom + (concat (upcase-initials (symbol-name idiom)) + (if name (concat ": " name)))) + ((or (eq type 'proof) (eq type 'goalsave)) + (concat "Proof" + (let ((name (span-property span 'name))) + (if name (concat " of " name))))) + ((eq type 'comment) "Comment") + ((eq type 'vanilla) "Command") + ((eq type 'pbp) "PBP command") + ((eq type 'proverproc) + "Prover-processed region")))) + +(defun pg-set-span-helphighlights (span &optional nohighlight) + "Set the help echo message, default highlight, and keymap for SPAN." + (let ((helpmsg (pg-span-name span))) + (set-span-property span 'balloon-help helpmsg) + (set-span-property span 'help-echo helpmsg) + (set-span-property span 'keymap pg-span-context-menu-keymap) + (unless nohighlight + (set-span-property span 'mouse-face 'proof-mouse-highlight-face)))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Multiple file handling +;; +(defun proof-complete-buffer-atomic (buffer) + "Make sure BUFFER is marked as completely processed, completing with a single step. + +If buffer already contains a locked region, only the remainder of the +buffer is closed off atomically. + +This works for buffers which are not in proof scripting mode too, +to allow other files loaded by proof assistants to be marked read-only." +;; NB: this isn't quite right, because not all of the structure in the +;; locked region will be preserved when processing across several +;; files. In particular, the span for a currently open goal should be +;; removed. Keeping the structure is an approximation to make up for +;; the fact that that no structure is created by loading files via the +;; proof assistant. Future ideas: proof assistant could ask Proof +;; General to do the loading, to alleviate file handling there; +;; we could cache meta-data resulting from processing files; +;; or even, could include parsing inside PG. + (save-excursion + (set-buffer buffer) + (if (< (proof-unprocessed-begin) (proof-script-end)) + (let ((span (make-span (proof-unprocessed-begin) + (proof-script-end))) + cmd) + (if (eq proof-buffer-type 'script) + ;; For a script buffer + (progn + (goto-char (point-min)) + (proof-goto-command-end) + (let ((cmd-list (member-if + (lambda (entry) (equal (car entry) 'cmd)) + (proof-segment-up-to (point))))) + ;; Reset queue and locked regions. + (proof-init-segmentation) + (if cmd-list + (progn + ;; FIXME 3.3 da: this can be simplified now, + ;; we don't need to set cmd for proverproc + (setq cmd (second (car cmd-list))) + (set-span-property span 'type 'proverproc) + (set-span-property span 'cmd cmd)) + ;; If there was no command in the buffer, atomic span + ;; becomes a comment. This isn't quite right because + ;; the first ACS in a buffer could also be a goal-save + ;; span. We don't worry about this in the current + ;; implementation. This case should not happen in a + ;; LEGO module (because we assume that the first + ;; command is a module declaration). It should have no + ;; impact in Isabelle either (because there is no real + ;; retraction). + (set-span-property span 'type 'comment)))) + ;; For a non-script buffer + (proof-init-segmentation) + (set-span-property span 'type 'comment)) + ;; End of locked region is always end of buffer + (proof-set-locked-end (proof-script-end)))))) + + + + + +;; FIXME da: cleanup of odd asymmetry here: we have a nice setting for +;; proof-register-possibly-new-processed-file but something much more +;; complicated for retracting, because we allow a hook function +;; to calculate the new included files list. + +(defun proof-register-possibly-new-processed-file (file &optional informprover noquestions) + "Register a possibly new FILE as having been processed by the prover. + +If INFORMPROVER is non-nil, the proof assistant will be told about this, +to co-ordinate with its internal file-management. (Otherwise we assume +that it is a message from the proof assistant which triggers this call). +In this case, the user will be queried to save some buffers, unless +NOQUESTIONS is non-nil. + +No action is taken if the file is already registered. + +A warning message is issued if the register request came from the +proof assistant and Emacs has a modified buffer visiting the file." + (let* ((cfile (file-truename file)) + (buffer (proof-file-to-buffer cfile))) + (proof-debug (concat "Registering file " cfile + (if (member cfile proof-included-files-list) + " (already registered, no action)." "."))) + (unless (member cfile proof-included-files-list) + (and buffer + (not informprover) + (buffer-modified-p buffer) + (proof-warning (concat "Changes to " + (buffer-name buffer) + " have not been saved!"))) + ;; Add the new file onto the front of the list + (setq proof-included-files-list + (cons cfile proof-included-files-list)) + ;; If the file is loaded into a buffer, make sure it is completely locked + (if buffer + (proof-complete-buffer-atomic buffer)) + ;; Tell the proof assistant, if we should and if we can + (if (and informprover proof-shell-inform-file-processed-cmd) + (progn + ;; Markus suggests we should ask if the user wants to save + ;; the file now (presumably because the proof assistant + ;; might examine the file timestamp, or attempt to visit + ;; the file later??). + ;; Presumably it would be enough to ask about this file, + ;; not all files? + (if (and + proof-query-file-save-when-activating-scripting + (not noquestions)) + (unwind-protect + (save-some-buffers))) + ;; Tell the prover + (proof-shell-invisible-command + (proof-format-filename proof-shell-inform-file-processed-cmd + cfile) + 'wait)))))) + +(defun proof-inform-prover-file-retracted (rfile) + (if proof-shell-inform-file-retracted-cmd + (proof-shell-invisible-command + (proof-format-filename proof-shell-inform-file-retracted-cmd + rfile) + 'wait))) + +(defun proof-auto-retract-dependencies (cfile &optional informprover) + "Perhaps automatically retract the (linear) dependencies of CFILE. +If proof-auto-multiple-files is nil, no action is taken. +If CFILE does not appear on proof-included-files-list, no action taken. + +Any buffers which are visiting files in proof-included-files-list +before CFILE are retracted using proof-protected-process-or-retract. +They are retracted in reverse order. + +Since the proof-included-files-list is examined, we expect scripting +to be turned off before calling here (because turning it off could +otherwise change proof-included-files-list). + +If INFORMPROVER is non-nil, the proof assistant will be told about this, +using proof-shell-inform-file-retracted-cmd, to co-ordinate with its +internal file-management. + +Files which are not visited by any buffer are not retracted, on the +basis that we may not have the information necessary to retract them +-- spans that cover the buffer with definition/declaration +information. A warning message is given for these cases, since it +could cause inconsistency problems. + +NB! Retraction can cause recursive calls of this function. +This is a subroutine for proof-unregister-buffer-file-name." + (if proof-auto-multiple-files + (let ((depfiles (reverse + (cdr-safe + (member cfile (reverse proof-included-files-list))))) + rfile rbuf) + (while (setq rfile (car-safe depfiles)) + ;; If there's a buffer visiting a dependent file, retract it. + ;; We test that the file to retract hasn't been retracted + ;; already by a recursive call here. (But since we do retraction + ;; in reverse order, this shouldn't happen...) + (if (and (member rfile proof-included-files-list) + (setq rbuf (proof-file-to-buffer rfile))) + (progn + (proof-debug "Automatically retracting " rfile) + (proof-protected-process-or-retract 'retract rbuf) + (setq proof-included-files-list + (delete rfile proof-included-files-list)) + ;; Tell the proof assistant, if we should and we can. + ;; This may be useful if we synchronise the *prover* with + ;; PG's management of multiple files. If the *prover* + ;; informs PG (better case), then we hope the prover will + ;; retract dependent files and we shouldn't use this + ;; degenerate (linear dependency) code. + (if informprover + (proof-inform-prover-file-retracted rfile))) + ;; If no buffer available, issue a warning that nothing was done + (proof-warning "Not retracting unvisited file " rfile)) + (setq depfiles (cdr depfiles)))))) + +(defun proof-unregister-buffer-file-name (&optional informprover) + "Remove current buffer's filename from the list of included files. +No effect if the current buffer has no file name. +If INFORMPROVER is non-nil, the proof assistant will be told about this, +using proof-shell-inform-file-retracted-cmd, to co-ordinate with its +internal file-management. + +If proof-auto-multiple-files is non-nil, any buffers on +proof-included-files-list before this one will be automatically +retracted using proof-auto-retract-dependencies." + (if buffer-file-name + (let ((cfile (file-truename + (or buffer-file-name + proof-script-buffer-file-name)))) + (proof-debug (concat "Unregistering file " cfile + (if (not (member cfile + proof-included-files-list)) + " (not registered, no action)." "."))) + (if (member cfile proof-included-files-list) + (progn + (proof-auto-retract-dependencies cfile informprover) + (setq proof-included-files-list + (delete cfile proof-included-files-list)) + ;; Tell the proof assistant, if we should and we can. + ;; This case may be useful if there is a combined + ;; management of multiple files between PG and prover. + (if informprover + (proof-inform-prover-file-retracted cfile))))))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Activating and Deactivating Scripting +;; +;; The notion of "active scripting buffer" clarifies how +;; scripting across multiple files is handled. Only one +;; script buffer is allowed to be active, and actions are +;; taken when scripting is turned off/on. +;; + +(defun proof-protected-process-or-retract (action &optional buffer) + "If ACTION='process, process, If ACTION='retract, retract. +Process or retract the current buffer, which should be the active +scripting buffer, according to ACTION. +Retract buffer BUFFER if set, otherwise use the current buffer. +Gives a message in the minibuffer and busy-waits for the retraction +or processing to complete. If it fails for some reason, +an error is signalled here." + (let ((fn (cond ((eq action 'process) 'proof-process-buffer) + ((eq action 'retract) 'proof-retract-buffer))) + (name (cond ((eq action 'process) "Processing") + ((eq action 'retract) "Retracting"))) + (buf (or buffer (current-buffer)))) + (if fn + (unwind-protect + (with-current-buffer buf + (message "%s buffer %s..." name buf) + (funcall fn) + (while proof-shell-busy ; busy wait + (sit-for 1)) + (message "%s buffer %s...done." name buf) + (sit-for 0)) + ;; Test to see if action was successful + (with-current-buffer buf + (or (and (eq action 'retract) (proof-locked-region-empty-p)) + (and (eq action 'process) (proof-locked-region-full-p)) + (error "%s of %s failed!" name buf))))))) + +(defun proof-deactivate-scripting-auto () + "Deactivate scripting without asking questions or raising errors. +If the locked region is full, register the file as processed. +Otherwise retract it. Errors are ignored" + (ignore-errors + (proof-deactivate-scripting + (proof-with-script-buffer + (if (proof-locked-region-full-p) 'process 'retract))))) + +(defun proof-deactivate-scripting (&optional forcedaction) + "Deactivate scripting for the active scripting buffer. + +Set proof-script-buffer to nil and turn off the modeline indicator. +No action if there is no active scripting buffer. + +We make sure that the active scripting buffer either has no locked +region or a full locked region (everything in it has been processed). +If this is not already the case, we question the user whether to +retract or assert, or automatically take the action indicated in the +user option `proof-auto-action-when-deactivating-scripting.' + +If the scripting buffer is (or has become) fully processed, and it is +associated with a file, it is registered on +`proof-included-files-list'. Conversely, if it is (or has become) +empty, we make sure that it is *not* registered. This is to be +certain that the included files list behaves as we might expect with +respect to the active scripting buffer, in an attempt to harmonize +mixed scripting and file reading in the prover. + +This function either succeeds, fails because the user refused to +process or retract a partly finished buffer, or gives an error message +because retraction or processing failed. If this function succeeds, +then proof-script-buffer is nil afterwards. + +The optional argument FORCEDACTION overrides the user option +`proof-auto-action-when-deactivating-scripting' and prevents +questioning the user. It is used to make a value for +the kill-buffer-hook for scripting buffers, so that when +a scripting buffer is killed it is always retracted." + (interactive) + (if proof-script-buffer + (with-current-buffer proof-script-buffer + ;; Examine buffer. + + ;; We must ensure that the locked region is either + ;; empty or full, to make sense for multiple-file + ;; scripting. (A proof assistant won't be able to + ;; process just part of a file typically; moreover + ;; switching between buffers during a proof makes + ;; no sense.) + (if (or (proof-locked-region-empty-p) + (proof-locked-region-full-p) + ;; Buffer is partly-processed + (let* + ((action + (or + forcedaction + proof-auto-action-when-deactivating-scripting + (progn + (save-window-excursion + (unless + ;; Test to see whether to display the + ;; buffer or not. + ;; Could have user option here to avoid switching + ;; or maybe borrow similar standard setting + ;; save-some-buffers-query-display-buffer + (or + (eq (current-buffer) + (window-buffer (selected-window))) + (eq (selected-window) (minibuffer-window))) + (progn + (unless (one-window-p) + (delete-other-windows)) + (switch-to-buffer proof-script-buffer t))) + ;; Would be nicer to ask a single question, but + ;; a nuisance to define our own dialogue since it + ;; doesn't really fit with one of the standard ones. + (cond + ((y-or-n-p + (format + "Scripting incomplete in buffer %s, retract? " + proof-script-buffer)) + 'retract) + ((y-or-n-p + (format + "Completely process buffer %s instead? " + proof-script-buffer)) + 'process))))))) + ;; Take the required action + (if action + (proof-protected-process-or-retract action) + ;; Give an acknowledgement to user's choice + ;; neither to assert or retract. + (message "Scripting still active in %s" + proof-script-buffer) + ;; Delay because this can be followed by an error + ;; message in proof-activate-scripting when trying + ;; to switch to another scripting buffer. + (sit-for 1) + nil))) + + ;; If we get here, then the locked region is (now) either + ;; completely empty or completely full. + (progn + ;; We can immediately indicate that there is no active + ;; scripting buffer + (setq proof-previous-script-buffer proof-script-buffer) + (setq proof-script-buffer nil) + + (if (proof-locked-region-full-p) + ;; If locked region is full, make sure that this buffer + ;; is registered on the included files list, and + ;; let the prover know it can consider it processed. + (if (or buffer-file-name proof-script-buffer-file-name) + (proof-register-possibly-new-processed-file + (or buffer-file-name proof-script-buffer-file-name) + 'tell-the-prover + forcedaction))) + + (if (proof-locked-region-empty-p) + ;; If locked region is empty, make sure this buffer is + ;; *off* the included files list. + ;; FIXME: probably this isn't necessary: the + ;; file should be unregistered by the retract + ;; action, or in any case since it was only + ;; partly processed. + ;; FIXME 2: be careful about automatic + ;; multiple file handling here, since it calls + ;; for activating scripting elsewhere. + ;; We move the onus on unregistering now to + ;; the activate-scripting action. + (proof-unregister-buffer-file-name)) + + ;; Turn off Scripting indicator here. + (setq proof-active-buffer-fake-minor-mode nil) + + ;; Make status of inactive scripting buffer show up + ;; FIXME da: + ;; not really necessary when called by kill buffer, at least. + (if (fboundp 'redraw-modeline) + (redraw-modeline) + (force-mode-line-update))))))) + +(defun proof-activate-scripting (&optional nosaves queuemode) + "Ready prover and activate scripting for the current script buffer. + +The current buffer is prepared for scripting. No changes are +necessary if it is already in Scripting minor mode. Otherwise, it +will become the new active scripting buffer, provided scripting +can be switched off in the previous active scripting buffer +with `proof-deactivate-scripting'. + +Activating a new script buffer may be a good time to ask if the +user wants to save some buffers; this is done if the user +option `proof-query-file-save-when-activating-scripting' is set +and provided the optional argument NOSAVES is non-nil. + +The optional argument QUEUEMODE relaxes the test for a +busy proof shell to allow one which has mode QUEUEMODE. +In all other cases, a proof shell busy error is given. + +Finally, the hooks `proof-activate-scripting-hook' are run. +This can be a useful place to configure the proof assistant for +scripting in a particular file, for example, loading the +correct theory, or whatever. If the hooks issue commands +to the proof assistant (via `proof-shell-invisible-command') +which result in an error, the activation is considered to +have failed and an error is given." + (interactive) + ;; FIXME: the scope of this save-excursion is rather wide. + ;; Problems without it however: Use button behaves oddly + ;; when process is started already. + ;; Where is save-excursion needed? + ;; First experiment shows that it's the hooks that cause + ;; problem, maybe even the use of proof-cd-sync (can't see why). + (save-excursion + ;; FIXME: proof-shell-ready-prover here s + (proof-shell-ready-prover queuemode) + (cond + ((not (eq proof-buffer-type 'script)) + (error "Must be running in a script buffer!")) + + ;; If the current buffer is the active one there's nothing to do. + ((equal (current-buffer) proof-script-buffer)) + + ;; Otherwise we need to activate a new Scripting buffer. + (t + ;; If there's another buffer currently active, we need to + ;; deactivate it (also fixing up the included files list). + (if proof-script-buffer + (progn + (proof-deactivate-scripting) + ;; Test whether deactivation worked + (if proof-script-buffer + (error + "You cannot have more than one active scripting buffer!")))) + + ;; Now make sure that this buffer is off the included files + ;; list. In case we re-activate scripting in an already + ;; completed buffer, it may be that the proof assistant + ;; needs to retract some of this buffer's dependencies. + (proof-unregister-buffer-file-name 'tell-the-prover) + + ;; If automatic retraction happened in the above step, we may + ;; have inadvertently activated scripting somewhere else. + ;; Better turn it off again. This should succeed trivially. + ;; NB: it seems that we could move the first test for an already + ;; active buffer here, but it is more subtle: the first + ;; deactivation can extend the proof-included-files list, which + ;; would affect what retraction was done in + ;; proof-unregister-buffer-file-name. + (if proof-script-buffer + (proof-deactivate-scripting)) + (assert (null proof-script-buffer) + "Bug in proof-activate-scripting: deactivate failed.") + + ;; Set the active scripting buffer, and initialise the + ;; queue and locked regions if necessary. + (setq proof-script-buffer (current-buffer)) + (if (proof-locked-region-empty-p) + ;; This removes any locked region that was there, but + ;; sometimes we switch on scripting in "full" buffers, + ;; so mustn't do this. + (proof-init-segmentation)) + + ;; Turn on the minor mode, make it show up. + (setq proof-active-buffer-fake-minor-mode t) + (if (fboundp 'redraw-modeline) + (redraw-modeline) + (force-mode-line-update)) + + ;; This may be a good time to ask if the user wants to save some + ;; buffers. On the other hand, it's jolly annoying to be + ;; queried on the active scripting buffer if we've started + ;; writing in it. So pretend that one is unmodified, at least + ;; (we certainly don't expect the proof assitant to load it) + (if (and + proof-query-file-save-when-activating-scripting + (not nosaves)) + (let ((modified (buffer-modified-p))) + (set-buffer-modified-p nil) + (unwind-protect + (save-some-buffers) + (set-buffer-modified-p modified)))) + + ;; Run hooks with a variable which suggests whether or not + ;; to block. NB: The hook function may send commands to the + ;; process which will re-enter this function, but should exit + ;; immediately because scripting has been turned on now. + (if proof-activate-scripting-hook + (let + ((activated-interactively (interactive-p))) + ;; Clear flag in case no hooks run shell commands + (setq proof-shell-error-or-interrupt-seen nil) + (run-hooks 'proof-activate-scripting-hook) + ;; In case the activate scripting functions + ;; caused an error in the proof assistant, we'll + ;; consider activating scripting to have failed, + ;; and raise an error here. + ;; (Since this behaviour is intimate with the hook functions, + ;; it could be removed and left to implementors of + ;; specific instances of PG). + ;; FIXME: we could consider simply running the hooks + ;; as the last step before turning on scripting properly, + ;; provided the hooks don't inspect proof-script-buffer. + (if proof-shell-error-or-interrupt-seen + (progn + (proof-deactivate-scripting) ;; turn it off again! + ;; Give an error to prevent further actions. + (error "Proof General: Scripting not activated because of error or interrupt."))))))))) + + +(defun proof-toggle-active-scripting (&optional arg) + "Toggle active scripting mode in the current buffer. +With ARG, turn on scripting iff ARG is positive." + (interactive "P") + ;; A little less obvious than it may seem: toggling scripting in the + ;; current buffer may involve turning it off in some other buffer + ;; first! + (if (if (null arg) + (not (eq proof-script-buffer (current-buffer))) + (> (prefix-numeric-value arg) 0)) + (progn + (if proof-script-buffer + (call-interactively 'proof-deactivate-scripting)) + (call-interactively 'proof-activate-scripting)) + (call-interactively 'proof-deactivate-scripting))) + +;; +;; End of activating and deactivating scripting section +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Processing the script management queue -- PART 1: "advancing" +;; +;; The proof-action-list contains a list of (span,command,action) +;; triples. The loop looks like: Execute the command, and if it's +;; successful, do action on span. If the command's not successful, we +;; bounce the rest of the queue and do some error processing. +;; +;; When a span has been processed, it is classified as +;; 'comment, 'goalsave, 'vanilla, etc. +;; +;; The main function for dealing with processed spans is +;; `proof-done-advancing' + +(defun proof-done-advancing (span) + "The callback function for assert-until-point." + ;; FIXME da: if the buffer dies, this function breaks horribly. + (if (not (span-live-p span)) + ;; NB: Sometimes this function is called with a destroyed + ;; extent as argument. Seems odd. + (proof-debug + "Proof General idiosyncrasy: proof-done-advancing called with a dead span!") + ;; + (let ((end (span-end span)) + (cmd (span-property span 'cmd))) + ;; State of spans after advancing: + (proof-set-locked-end end) + ;; FIXME: buglet here, can sometimes arrive with queue span already detached. + ;; (I think when complete file process is requested during scripting) + (if (span-live-p proof-queue-span) + (proof-set-queue-start end)) + + (cond + ;; CASE 1: Comments just get highlighted + ((eq (span-property span 'type) 'comment) + (proof-done-advancing-comment span)) + + ;; CASE 2: Save command seen, now we may amalgamate spans. + ((and proof-save-command-regexp + (proof-string-match proof-save-command-regexp cmd) + ;; FIXME: would like to get rid of proof-really-save-command-p + ;; and use nested goals mechanism instead. + (funcall proof-really-save-command-p span cmd) + (decf proof-nesting-depth) ;; [always non-nil/true] + (if proof-nested-goals-history-p + ;; For now, we only support this nesting behaviour: + ;; don't amalgamate unless the nesting depth is 0, + ;; i.e. we're in a top-level proof. + ;; This assumes prover keeps history for nested proofs. + ;; (True for Isabelle/Isar). + (eq proof-nesting-depth 0) + t)) + (proof-done-advancing-save span)) + + ;; CASE 3: Proof completed one step or more ago, non-save + ;; command seen, no nested goals allowed. + ;; + ;; We make a fake goal-save from any previous + ;; goal to the command before the present one. + ;; + ;; This allows smooth undoing in proofs which have no "qed" + ;; statements. If your proof assistant doesn't allow these + ;; "unclosed" proofs, then you can safely set + ;; proof-completed-proof-behaviour. + ((and + proof-shell-proof-completed + (or (and (eq proof-completed-proof-behaviour 'extend) + (>= proof-shell-proof-completed 0)) + (and (eq proof-completed-proof-behaviour 'closeany) + (> proof-shell-proof-completed 0)) + (and (eq proof-completed-proof-behaviour 'closegoal) + (funcall proof-goal-command-p cmd)))) + (proof-done-advancing-autosave span)) + + ;; CASE 4: Some other kind of command (or a nested goal). + (t + (proof-done-advancing-other span)))) + + ;; Finally: state of scripting may have changed now, run hooks. + (run-hooks 'proof-state-change-hook))) + + + +(defun proof-done-advancing-comment (span) + "A subroutine of `proof-done-advancing'" + ;; Add an element for a new span, which should span + ;; the text of the comment. + ;; FIXME: might be better to use regexps for matching + ;; start/end of comments, rather than comment-start-skip + (let ((bodyspan (make-span + (+ (length comment-start) (span-start span)) + (- (span-end span) (length comment-end)))) + (id (proof-next-element-id 'comment))) + (pg-add-element "comment" id bodyspan) + (set-span-property span 'id (intern id)) + (set-span-property span 'idiom 'comment) + (pg-set-span-helphighlights span))) + + +(defun proof-done-advancing-save (span) + "A subroutine of `proof-done-advancing'" + (unless (eq proof-shell-proof-completed 1) + ;; We expect saves to succeed only for recently completed proofs. + ;; Give a hint to the proof assistant implementor in case something + ;; odd is going on. (NB: this is normal for nested proofs, though). + (proof-debug + (format + "PG: save command with proof-shell-proof-completed=%s, proof-nesting-depth=%s" + proof-shell-proof-completed proof-nesting-depth))) + + (setq proof-shell-proof-completed nil) + + ;; FIXME: need subroutine here: + (let ((gspan span) ; putative goal span + (savestart (span-start span)) + (saveend (span-end span)) + (cmd (span-property span 'cmd)) + lev nestedundos nam next ncmd) + + ;; Try to set the name of the theorem from the save + ;; (message "%s" cmd) 3.4: remove this message. + + (and proof-save-with-hole-regexp + (proof-string-match proof-save-with-hole-regexp cmd) + ;; Give a message of a name if one can be determined + (message "%s" + (setq nam + (if (stringp proof-save-with-hole-result) + (replace-match proof-save-with-hole-result nil nil cmd) + (match-string proof-save-with-hole-result cmd))))) + + ;; Search backwards for matching goal command, deleting spans + ;; along the way: they will be amalgamated into a single + ;; goal-save region, which corresponds to the prover + ;; discarding the proof history. + ;; Provers without flat history yet nested proofs (i.e. Coq) + ;; need to keep a record of the undo count for nested goalsaves. + ;; FIXME: should also remove nested 'idiom spans, perhaps. + (setq lev 1) + (setq nestedundos 0) + (while (and gspan (> lev 0)) + (setq next (prev-span gspan 'type)) + (delete-span gspan) + (setq gspan next) + (if gspan + (progn + (setq cmd (span-property gspan 'cmd)) + (cond + ;; Ignore comments [may have null cmd setting] + ((eq (span-property gspan 'type) 'comment)) + ;; Nested goal saves: add in any nestedcmds + ((eq (span-property gspan 'type) 'goalsave) + (setq nestedundos + (+ nestedundos 1 + (or (span-property gspan 'nestedundos) 0)))) + ;; Increment depth for a nested save, in case + ;; prover supports history of nested proofs + ((and proof-nested-goals-history-p + proof-save-command-regexp + (proof-string-match proof-save-command-regexp cmd)) + (incf lev)) + ;; Decrement depth when a goal is hit + ((funcall proof-goal-command-p cmd) + (decf lev)) + ;; Remainder cases: see if command matches something we + ;; should count for a global undo + ((and proof-nested-undo-regexp + (proof-string-match proof-nested-undo-regexp cmd)) + (incf nestedundos)) + )))) + + (if (not gspan) + ;; No goal span found! Issue a warning and do nothing more. + (proof-warning + "Proof General: script management confused, couldn't find goal span for save.") + + ;; If the name isn't set, try to set it from the goal, + ;; or as a final desparate attempt, set the name to + ;; proof-unnamed-theorem-name (Coq actually uses a default + ;; name for unnamed theorems, believe it or not, and issues + ;; a name-binding error for two unnamed theorems in a row!). + (setq nam (or nam + (proof-get-name-from-goal gspan) + proof-unnamed-theorem-name)) + + (proof-make-goalsave gspan (span-end gspan) + savestart saveend nam nestedundos) + + ;; *** Theorem dependencies *** + (if proof-last-theorem-dependencies + (proof-depends-process-dependencies nam gspan))))) + +(defun proof-make-goalsave (gspan goalend savestart saveend nam &optional nestedundos) + "Make new goal-save span, using GSPAN. Subroutine of `proof-done-advancing-save'" + (set-span-end gspan saveend) + (set-span-property gspan 'type 'goalsave) + (set-span-property gspan 'idiom 'proof);; links to nested proof element + (set-span-property gspan 'name nam) + (and nestedundos (set-span-property gspan 'nestedundos nestedundos)) + (pg-set-span-helphighlights gspan) + ;; Now make a nested span covering the purported body of the + ;; proof, and add to buffer-local list of elements. + (let ((proofbodyspan + (make-span goalend (if proof-script-integral-proofs + saveend savestart)))) + (pg-add-proof-element nam proofbodyspan gspan))) + +(defun proof-get-name-from-goal (gspan) + "Try to return a goal name from GSPAN. Subroutine of `proof-done-advancing-save'" + (let ((cmdstr (span-property gspan 'cmd))) + (and proof-goal-with-hole-regexp + (proof-string-match proof-goal-with-hole-regexp cmdstr) + (if (stringp proof-goal-with-hole-result) + (replace-match proof-goal-with-hole-result nil nil cmdstr) + (match-string proof-goal-with-hole-result cmdstr))))) + + +;; FIXME: this next function should be more like proof-done-advancing-save, +;; perhaps simplifying the proof-completed-proof-behaviour functionality, +;; which isn't seriously used in any prover. At the moment the behaviour +;; here is incomplete compared with proof-done-advancing-save. +;; NB: in this function we assume non-nested proofs, which explains +;; some of the logic. There is no attempt to fix up proof-nesting-depth. +;; NB: 'extend behaviour is not currently compatible with appearance of +;; save commands, since proof-done-advancing-save allow for goalspan +;; already existing. +(defun proof-done-advancing-autosave (span) + "A subroutine of `proof-done-advancing'" + + ;; In the extend case, the context of proof grows until hit a save + ;; or new goal. + (if (eq proof-completed-proof-behaviour 'extend) + (incf proof-shell-proof-completed) + (setq proof-shell-proof-completed nil)) + + (let* ((swallow (eq proof-completed-proof-behaviour 'extend)) + (gspan (if swallow span (prev-span span 'type))) + (newend (if swallow (span-end span) (span-start span))) + (cmd (span-property span 'cmd)) + (newgoal (funcall proof-goal-command-p cmd)) + nam hitsave dels ncmd) + ;; Search backwards to see if we can find a previous goal + ;; before a save or the start of the buffer. + ;; FIXME: this should really do the work done in + ;; proof-done-advancing-save above, too, with nested undos, etc. + (while ;; YUK! + (and + gspan + (or + (eq (span-property gspan 'type) 'comment) + (and + (setq ncmd (span-property gspan 'cmd)) + (not (funcall proof-goal-command-p (setq cmd ncmd))) + (not + (and proof-save-command-regexp + (proof-string-match proof-save-command-regexp cmd) + (funcall proof-really-save-command-p span cmd) + (setq hitsave t)))))) + (setq dels (cons gspan dels)) + (setq gspan (prev-span gspan 'type))) + (cond + ((or hitsave (null gspan)) + (proof-debug + "Proof General strangeness: unclosed proof completed, but couldn't find its start!") + (pg-set-span-helphighlights span)) + ((and swallow newgoal) + ;; If extending the region, goalsave already there; just highlight new region + (setq proof-shell-proof-completed nil) + (pg-set-span-helphighlights span)) + (t + ;; If, search back through spans, we haven't hit a save or the + ;; start of the buffer, we make a fake goal-save region. + + ;; Delete spans between the previous goal and new command + (mapcar 'delete-span dels) + + ;; Try to set the name from the goal... [as above] + (setq nam (or (proof-get-name-from-goal gspan) + proof-unnamed-theorem-name)) + + ;; NB: if extending an already closed region, ought to delete + ;; the body and extend that too: currently we make multiple nested + ;; bodies, a bit messy. + ;; (NB: savestart used for nested region: here use saveend) + (proof-make-goalsave gspan + (+ (span-start gspan) + (length (or (span-property-safe gspan 'cmd)))) + newend newend nam))))) + +(defun proof-done-advancing-other (span) + ;; We might add hidable regions also for commands: the problem + ;; is that they have no natural surrounding region, so makes + ;; it difficult to define a region for revealing again. + ;; [ best solution would be to support clicking on ellipsis] + (if (funcall proof-goal-command-p (span-property span 'cmd)) + (incf proof-nesting-depth)) + + (if proof-shell-proof-completed + (incf proof-shell-proof-completed)) + + (pg-set-span-helphighlights span)) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Parsing functions for parsing commands in script +;; +;; Command parsing is suprisingly subtle with various possibilities of +;; command syntax (terminated, not terminated, or lisp-style); whether +;; or not PG silently ignores comments, etc. + +;; FIXME: currently there's several sets of functions. We need to be +;; more general and a bit more clear, but the latest versions are a +;; much better attempt. + +(defun proof-segment-up-to-parser (pos &optional next-command-end) + "Parse the script buffer from end of locked to POS. +Return a list of (type, string, int) tuples (in reverse order). + +Each tuple denotes the command and the position of its final character, +type is one of 'comment, or 'cmd. + +The behaviour around comments is set by +`proof-script-fly-past-comments', which see. + +This version is used when `proof-script-parse-function' is set, +to the function which parses the script segment by segment." + (save-excursion + (let* ((start (goto-char (proof-queue-or-locked-end))) + (cur (1- start)) + (seg t) + prevtype realstart cmdseen segs) + ;; Keep parsing until: + ;; - we fail to find a segment (seg = nil) + ;; - we go beyond the stop point (cur >= end) + ;; - unless we're flying past comments, in which case + ;; wait for a command (cmdseen<>nil) + (while (and seg + (or (< cur pos) + (and proof-script-fly-past-comments + (not cmdseen)))) + ;; Skip whitespace before this element + (skip-chars-forward " \t\n") + (setq realstart (point)) + (let* ((type (funcall proof-script-parse-function))) + (setq seg nil) + (cond + ((eq type 'comment) + (setq seg (list 'comment "" (point)))) + ((eq type 'cmd) + (setq cmdseen t) + (setq seg (list + 'cmd + (buffer-substring realstart (point)) + (point)))) + ((null type)) ; nothing left in buffer + (t + (error + "proof-segment-up-to-parser: bad TYPE value from proof-script-parse-function."))) + ;; + (if seg + (progn + ;; Add the new segment, coalescing comments if + ;; the user likes it that way. I first made + ;; coalescing a separate configuration option, but + ;; it works well used in tandem with the fly-past + ;; behaviour. + (if (and proof-script-fly-past-comments + (eq type 'comment) + (eq prevtype 'comment)) + (setq segs (cons seg (cdr segs))) + (setq segs (cons seg segs))) + ;; Update state + (setq cur (point)) + (setq prevtype type))))) + ;; Return segment list + segs))) + +(defun proof-script-generic-parse-find-comment-end () + "Find the end of the comment point is at the start of. Nil if not found." + (let ((notout t)) + ;; Find end of comment (NB: doesn't undertand nested comments) + (while (and notout (re-search-forward + proof-script-comment-end-regexp nil 'movetolimit)) + (setq notout (proof-buffer-syntactic-context))) + (not (proof-buffer-syntactic-context)))) + +(defun proof-script-generic-parse-cmdend () + "Used for proof-script-parse-function if proof-script-command-end-regexp is set." + (if (looking-at proof-script-comment-start-regexp) + ;; Handle comments + (if (proof-script-generic-parse-find-comment-end) 'comment) + ;; Handle non-comments: assumed to be commands + (let (foundend) + ;; Find end of command + (while (and (setq foundend + (re-search-forward proof-script-command-end-regexp nil t)) + (proof-buffer-syntactic-context)) + ;; inside a string or comment before the command end + ) + (if (and foundend + (not (proof-buffer-syntactic-context))) + ;; Found command end outside string/comment + 'cmd + ;; Didn't find command end + nil)))) + +(defun proof-script-generic-parse-cmdstart () + "For proof-script-parse-function if proof-script-command-start-regexp is set." + ;; This was added for the fine-grained command structure of Isar + ;; + ;; It's is a lot more involved than the case of just scanning for + ;; the command end; we have to find two successive command starts + ;; and go backwards from the second. This coalesces comments + ;; following commands with commands themselves, and sends them to + ;; the prover (only case where it does). It's needed particularly + ;; for Isar's text command (text {* foo *}) so we can define the + ;; buffer syntax for text as a comment. + ;; + ;; To avoid doing that, we would need to scan also for comments but + ;; it would be difficult to distinguish between: + ;; complete command (* that's it *) + ;; and + ;; complete (* almost *) command + ;; + ;; Maybe the second case should be disallowed in command-start regexp case? + ;; + ;; Another improvement idea might be to take into account both + ;; command starts *and* ends, but let's leave that for another day. + ;; + ;; NB: proof-script-comment-start-regexp doesn't need to be the same + ;; as (reqexp-quote comment-start). + (if (looking-at proof-script-comment-start-regexp) + ;; Find end of comment + (if (proof-script-generic-parse-find-comment-end) 'comment) + ;; Handle non-comments: assumed to be commands + (if (looking-at proof-script-command-start-regexp) + (progn + ;; We've got at least the beginnings of a command, skip past it + ;(re-search-forward proof-script-command-start-regexp nil t) + (goto-char (match-end 0)) + (let (foundstart) + ;; Find next command start + (while (and (setq + foundstart + (and + (re-search-forward proof-script-command-start-regexp + nil 'movetolimit) + (match-beginning 0))) + (proof-buffer-syntactic-context)) + ;; inside a string or comment before the next command start + ) + (if (not (proof-buffer-syntactic-context)) ; not inside a comment/string + (if foundstart ; found a second command start + (progn + (goto-char foundstart) ; beginning of command start + (skip-chars-backward " \t\n") ; end of previous command + 'cmd) + (if (eq (point) (point-max)) ; At the end of the buffer + (progn + (skip-chars-backward " \t\n") ; benefit of the doubt, let + 'cmd)))) ; the PA moan if it's incomplete + ;; Return nil in other cases, no complete command found + ))))) + + +(defun proof-script-generic-parse-sexp () + "Used for proof-script-parse-function if proof-script-sexp-commands is set." + ;; Usual treatment of comments + (if (looking-at proof-script-comment-start-regexp) + ;; Find end of comment + (if (proof-script-generic-parse-find-comment-end) 'comment) + (let* ((parse-sexp-ignore-comments t) ; gobble comments into commands + (end (scan-sexps (point) 1))) + (if end + (progn (goto-char end) 'cmd))))) + + +;; Parsing functions new in v3.2 +;; +;; NB: compared with old code, +;; (1) this doesn't treat comments quite so well, but parsing +;; should be rather more efficient. +;; (2) comments are treated less like commands, and are only +;; coloured blue "in passing" when commands are sent. +;; However, undo still process comments step-by-step. + +(defun proof-segment-up-to-cmdstart (pos &optional next-command-end) + "Parse the script buffer from end of locked to POS. +Return a list of (type, string, int) tuples. + +Each tuple denotes the command and the position of its terminator, +type is one of 'comment, or 'cmd. + +If optional NEXT-COMMAND-END is non-nil, we include the command +which continues past POS, if any. (NOT IMPLEMENTED IN THIS VERSION). + +This version is used when `proof-script-command-start-regexp' is set." + (save-excursion + (let* ((commentre (concat "[ \t\n]*" proof-script-comment-start-regexp)) + (commentend (concat proof-script-comment-end-regexp "[ \t\n]*" )) + (add-segment-for-cmd ; local function: advances "prev" + (lambda () + (setq tmp (point)) + ;; Find end of previous command... + (goto-char comstart) + ;; Special hack: allow terminal char to be included + ;; in a command, if it's set. + (if (and proof-terminal-char + (looking-at + (regexp-quote (char-to-string proof-terminal-char)))) + (goto-char (1+ (point))) + (skip-chars-backward " \t\n")) + (let* ((prev-no-blanks + (save-excursion + (goto-char prev) + (skip-chars-forward " \t\n") + (point))) + (comend (point)) + (bufstr (buffer-substring prev-no-blanks comend)) + (type (save-excursion + ;; The behaviour here is a bit odd: this + ;; is a half-hearted attempt to strip comments + ;; as we send text to the proof assistant, + ;; but it breaks when we have certain bad + ;; input: (* foo *) blah (* bar *) cmd + ;; We check for the case + ;; of a comment spanning the *whole* + ;; substring, otherwise send the + ;; (defective) text as if it were a + ;; proper command anyway. + ;; This shouldn't cause problems: the + ;; proof assistant is certainly capable + ;; of skipping comments itself, and + ;; the situation should cause an error. + ;; (If it were accepted it could upset the + ;; undo behaviour) + (goto-char prev-no-blanks) + ;; Update: PG 3.4: try to deal with sequences + ;; of comments as well, since previous behaviour + ;; breaks Isar, in fact, since repeated + ;; comments get categorized as commands, + ;; breaking sync. + (if (and + (looking-at commentre) + (re-search-forward proof-script-comment-end-regexp) + (progn + (while (looking-at commentre) + (re-search-forward proof-script-comment-end-regexp)) + (>= (point) comend))) + 'comment 'cmd))) + (string (if (eq type 'comment) "" bufstr))) + (setq prev (point)) + (goto-char tmp) + ;; NB: Command string excludes whitespace, span includes it. + (setq alist (cons (list type string prev) alist))))) + alist prev cmdfnd startpos comstart tmp) + (goto-char (proof-queue-or-locked-end)) + (setq prev (point)) + (skip-chars-forward " \t\n") + (setq startpos (point)) + (while + (and + (proof-re-search-forward proof-script-command-start-regexp + nil t) ; search for next command + (setq comstart (match-beginning 0)); save command start + (or (save-excursion + (goto-char comstart) + ;; continue if inside (or at start of) comment/string + (proof-looking-at-syntactic-context)) + (progn ; or, if found command... + (setq cmdfnd + (> comstart startpos)); ignore first match + (<= prev pos)))) + (if cmdfnd (progn + (funcall add-segment-for-cmd) + (setq cmdfnd nil)))) + ;; End of parse; see if we found some text at the end of the + ;; buffer which could be a command. (NB: With a regexp for + ;; start of commands only, we can't be sure it is a complete + ;; command). + (if (and comstart ; previous command was found + (<= prev pos) ; last command within range + (goto-char (point-max)) + (setq comstart (point)) ; pretend there's another cmd here + (not (proof-buffer-syntactic-context))) ; buffer ends well + (funcall add-segment-for-cmd)) + ; (if (and cmdfnd next-command-end) + ; (funcall add-segment-for-cmd)) + ;; Return resulting list + alist))) + + +;; FIXME: this needs fixing to include final comment in buffer +;; if there is one!! + +(defun proof-segment-up-to-cmdend (pos &optional next-command-end) + "Parse the script buffer from end of locked to POS. +Return a list of (type, string, int) tuples. + +Each tuple denotes the command and the position of its terminator, +type is one of 'comment, or 'cmd. 'unclosed-comment may be consed onto +the start if the segment finishes with an unclosed comment. + +If optional NEXT-COMMAND-END is non-nil, we include the command +which continues past POS, if any. + +This version is used when `proof-script-command-end-regexp' is set." + (save-excursion + (let* + ((commentre (concat "[ \t\n]*" proof-script-comment-start-regexp)) + (add-segment-for-cmd ; local function: advances "prev" + (lambda () + (let ((cmdend (point)) start) + (goto-char prev) + ;; String may start with comments, let's strip them off + (while + (and + (setq start (point)) + (proof-re-search-forward commentre cmdend t) + (or (eq (match-beginning 0) start) + ;; In case a comment inside a command was found, make + ;; sure we're at the start of the cmd before exiting + (progn (goto-char start) nil))) + ;; Look for the end of the comment + ;; (FIXME: ignore nested comments here, we should + ;; have a consistent policy!) + (unless + (if (fboundp 'comment-forward) + (progn + (goto-char (or (match-end 1) (match-beginning 0))) + (comment-forward)) + (proof-re-search-forward + proof-script-comment-end-regexp cmdend t)) + (error + "PG error: proof-segment-up-to-cmd-end didn't find comment end")) + (setq alist (cons (list 'comment "" (point)) alist))) + ;; There should be something left: a command. + (skip-chars-forward " \t\n") + (setq alist (cons (list 'cmd + (buffer-substring + (point) cmdend) + cmdend) alist)) + (setq prev cmdend) + (goto-char cmdend)))) + alist prev cmdfnd startpos tmp) + (goto-char (proof-queue-or-locked-end)) + (setq prev (point)) + (skip-chars-forward " \t\n") + (setq startpos (point)) + (while + (and + (proof-re-search-forward proof-script-command-end-regexp + nil t) ; search for next command + (or (proof-buffer-syntactic-context) ; continue if inside comment/string + (progn ; or, if found command... + (setq cmdfnd t) + (<= (point) pos)))) + (if cmdfnd (progn + (funcall add-segment-for-cmd) + (setq cmdfnd nil)))) + ;; End of parse; if we found a command past POS maybe add it. + ;; FIXME: also, if we found a *comment* maybe add it! + (if cmdfnd ; (and cmdfnd next-command-end) + (funcall add-segment-for-cmd)) + ;; Return resulting list + alist))) + +(defun proof-semis-to-vanillas (semis &optional callback-fn) + "Convert a sequence of terminator positions to a set of vanilla extents. +Proof terminator positions SEMIS has the form returned by +the function proof-segment-up-to. +Set the callback to CALLBACK-FN or 'proof-done-advancing by default." + (let ((ct (proof-queue-or-locked-end)) span alist semi) + (while (not (null semis)) + (setq semi (car semis) + span (make-span ct (nth 2 semi)) + ct (nth 2 semi)) + (if (eq (car (car semis)) 'cmd) + (progn + (set-span-property span 'type 'vanilla) + (set-span-property span 'cmd (nth 1 semi)) + (setq alist (cons (list span (nth 1 semi) + (or callback-fn 'proof-done-advancing)) + alist))) + (set-span-property span 'type 'comment) + (setq alist (cons (list span proof-no-command 'proof-done-advancing) + alist))) + (setq semis (cdr semis))) + (nreverse alist))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Assert-until-point and friends. +;; +;; These functions parse some region of the script buffer into +;; commands, and add the commands into the queue. +;; + + +;; First: two commands for moving forwards in proof scripts. Moving +;; forward for a "new" command may insert spaces or new lines. Moving +;; forward for the "next" command does not. + +(defun proof-script-new-command-advance () + "Move point to a nice position for a new command. +Assumes that point is at the end of a command." + (interactive) +; FIXME: pending improvement.2, needs a fix here. +; (if (eq (proof-locked-end) (point)) +; ;; A hack to fix problem that the locked span +; ;; is [ ) so sometimes inserting at the end +; ;; tries to extend it, giving "read only" error. +; (if (> (point-max) (proof-locked-end)) +; (progn +; (goto-char (1+ (proof-locked-end))) +; (backward-char)))) + (if proof-one-command-per-line + ;; One command per line: move to next new line, creating one if + ;; at end of buffer or at the start of a blank line. (This has + ;; the pleasing effect that blank regions of the buffer are + ;; automatically extended when inserting new commands). +; unfortunately if we're not at the end of a line to start, +; it skips past stuff to the end of the line! don't want +; that. +; (cond +; ((eq (forward-line) 1) +; (newline)) +; ((eolp) +; (newline) +; (forward-line -1))) + (newline) + ;; Multiple commands per line: skip spaces at point, and insert + ;; the 1/0 number of spaces that were skipped in front of point + ;; (at least one). This has the pleasing effect that the spacing + ;; policy of the current line is copied: e.g. <command>; + ;; <command>; Tab columns don't work properly, however. Instead + ;; of proof-one-command-per-line we could introduce a + ;; "proof-command-separator" to improve this. + (let ((newspace (max (skip-chars-forward " \t") 1)) + (p (point))) + (if proof-script-command-separator + (insert proof-script-command-separator) + (insert-char ?\ newspace) + (goto-char p))))) + +(defun proof-script-next-command-advance () + "Move point to the beginning of the next command if it's nearby. +Assumes that point is at the end of a command." + (interactive) + ;; skip whitespace on this line + (skip-chars-forward " \t") + (if (and proof-one-command-per-line (eolp)) + ;; go to the next line if we have one command per line + (forward-line))) + + +;; NB: the "interactive" variant is so that we get a simple docstring. +(defun proof-assert-until-point-interactive () + "Process the region from the end of the locked-region until point. +Default action if inside a comment is just process as far as the start of +the comment." + (interactive) + (proof-assert-until-point)) + + +;; Assert until point - We actually use this to implement the +;; assert-until-point, electric terminator keypress, and +;; goto-command-end. In different cases we want different things, but +;; usually the information (e.g. are we inside a comment) isn't +;; available until we've actually run proof-segment-up-to (point), +;; hence all the different options when we've done so. + +;; FIXME da: this command doesn't behave as the doc string says when +;; inside comments. Also is unhelpful at the start of commands, and +;; in the locked region. I prefer the new version below. + +;; FIXME: get rid of duplication between proof-assert-next-command and +;; proof-assert-until-point. Get rid of ignore process nonsense. + +;; FIXME: get rid of unclosed-comment-fun nonsense. It's used +;; in the electric terminator function, but we should probably +;; use something else for that! + +(defun proof-assert-until-point (&optional unclosed-comment-fun + ignore-proof-process-p) + "Process the region from the end of the locked-region until point. +Default action if inside a comment is just process as far as the start of +the comment. + +If you want something different, put it inside +UNCLOSED-COMMENT-FUN. If IGNORE-PROOF-PROCESS-P is set, no commands +will be added to the queue and the buffer will not be activated for +scripting." + (unless ignore-proof-process-p + (proof-activate-scripting nil 'advancing)) + (let ((semis)) + (save-excursion + ;; Give error if no non-whitespace between point and end of + ;; locked region. + (if (proof-only-whitespace-to-locked-region-p) + (error "At the end of the locked region already, there's nothing to do to!")) + ;; NB: (point) has now been moved backwards to first non-whitespace char. + (setq semis (proof-segment-up-to (point)))) + (if (and unclosed-comment-fun (eq 'unclosed-comment (car semis))) + (funcall unclosed-comment-fun) + (if (eq 'unclosed-comment (car semis)) (setq semis (cdr semis))) + (if (and (not ignore-proof-process-p) (null semis)) + ;; This is another case that there's nothing to do: maybe + ;; because inside a string or something. + (if (eq unclosed-comment-fun 'proof-electric-term-incomment-fn) + ;; With electric terminator, we shouldn't give an error, but + ;; should still insert and pretend it was as if a comment. + (proof-electric-term-incomment-fn) + (error "I can't find any complete commands to process!")) + (goto-char (nth 2 (car semis))) + (and (not ignore-proof-process-p) + (let ((vanillas (proof-semis-to-vanillas (nreverse semis)))) + (proof-extend-queue (point) vanillas))))))) + + +;; da: This is my alternative version of the above. +;; It works from the locked region too. +;; I find it more convenient to assert up to the current command (command +;; point is inside), and move to the next command. +;; This means proofs can be easily replayed with point at the start +;; of lines. Above function gives stupid "nothing to do error." when +;; point is on the start of line or in the locked region. + +;; FIXME: behaviour inside comments may be odd at the moment. (it +;; doesn't behave as docstring suggests, same prob as +;; proof-assert-until-point) +;; FIXME: polish the undo behaviour and quit behaviour of this +;; command (should inhibit quit somewhere or other). + + + +(defun proof-assert-next-command + (&optional unclosed-comment-fun ignore-proof-process-p + dont-move-forward for-new-command) + "Process until the end of the next unprocessed command after point. +If inside a comment, just process until the start of the comment. + +If you want something different, put it inside UNCLOSED-COMMENT-FUN. +If IGNORE-PROOF-PROCESS-P is set, no commands will be added to the queue. +Afterwards, move forward to near the next command afterwards, unless +DONT-MOVE-FORWARD is non-nil. If FOR-NEW-COMMAND is non-nil, +a space or newline will be inserted automatically." + (interactive) + (unless ignore-proof-process-p + (proof-activate-scripting nil 'advancing)) + (or ignore-proof-process-p + (if (proof-locked-region-full-p) + (error "Locked region is full, no more commands to do!"))) + (let ((semis)) + (save-excursion + ;; CHANGE from old proof-assert-until-point: don't bother check + ;; for non-whitespace between locked region and point. + ;; CHANGE: ask proof-segment-up-to to scan until command end + ;; (which it used to do anyway, except in the case of a comment) + (setq semis (proof-segment-up-to (point) t))) + ;; old code: + ;;(if (not (re-search-backward "\\S-" (proof-unprocessed-begin) t)) + ;; (progn (goto-char pt) + ;; (error "I don't know what I should be doing in this buffer!"))) + ;; (setq semis (proof-segment-up-to (point)))) + (if (and unclosed-comment-fun (eq 'unclosed-comment (car-safe semis))) + (funcall unclosed-comment-fun) + (if (eq 'unclosed-comment (car-safe semis)) + (setq semis (cdr semis))) + (if (and (not ignore-proof-process-p) (null semis)) + (error "I can't see any complete commands to process!")) + (if (nth 2 (car semis)) + (goto-char (nth 2 (car semis)))) + (if (not ignore-proof-process-p) + (let ((vanillas (proof-semis-to-vanillas (nreverse semis)))) + (proof-extend-queue (point) vanillas))) + ;; This is done after the queuing to be polite: it means the + ;; spacing policy enforced here is not put into the locked + ;; region so the user can re-edit. + (if (not dont-move-forward) + (if for-new-command + (proof-script-new-command-advance) + (proof-script-next-command-advance)))))) + +(defun proof-goto-point () + "Assert or retract to the command at current position. +Calls proof-assert-until-point or proof-retract-until-point as +appropriate." + (interactive) + (if (<= (proof-queue-or-locked-end) (point)) + ;; This asserts only until the next command before point and + ;; does nothing if whitespace between point and locked region. + (proof-assert-until-point) + (proof-retract-until-point))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; PBP call-backs +;; +(defun proof-insert-pbp-command (cmd) + "Insert CMD into the proof queue." + (proof-activate-scripting) + (let (span) + (proof-goto-end-of-locked) + (insert cmd) + (setq span (make-span (proof-locked-end) (point))) + (set-span-property span 'type 'pbp) + (set-span-property span 'cmd cmd) + (proof-start-queue (proof-unprocessed-begin) (point) + (list (list span cmd 'proof-done-advancing))))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Processing the script management queue -- PART 2: retracting +;; + +;; Most of the hard work (computing the commands to do the retraction) +;; is implemented in the customisation module (lego.el or coq.el), so +;; code here is fairly straightforward. + + +;; FIXME: we need to adjust proof-nesting-depth appropriately here. +;; It would help to know the type of retraction which has just +;; occurred: a kill-proof may be assumed to set nesting depth +;; to zero; an undo sequence may alter it some other way. +;; FIXME FIXME: at the moment, the adjustment is made in +;; the wrong place!! + +(defun proof-done-retracting (span) + "Callback for proof-retract-until-point. +We update display after proof process has reset its state. +See also the documentation for `proof-retract-until-point'. +Optionally delete the region corresponding to the proof sequence. +After an undo, we clear the proof completed flag. The rationale +is that undoing never leaves prover in a \"proof just completed\" +state, which is true for some proof assistants (but probably not +others)." + ;; FIXME: need to fixup proof-nesting-depth + (setq proof-shell-proof-completed nil) + (if (span-live-p span) + (let ((start (span-start span)) + (end (span-end span)) + (kill (span-property span 'delete-me))) + ;; da: check for empty region seems odd here? + ;; [prevents regions from being detached in set-locked-end] + (unless (proof-locked-region-empty-p) + (proof-set-locked-end start) + (proof-set-queue-end start)) + (delete-spans start end 'type) + (delete-spans start end 'idiom) + (delete-span span) + (if kill (kill-region start end)))) + ;; State of scripting may have changed now + (run-hooks 'proof-state-change-hook)) + +(defun proof-setup-retract-action (start end proof-command delete-region) + "Make span from START to END which corresponds to retraction. +Returns retraction action destined for proof shell queue, and make span. +Action holds PROOF-COMMAND and `proof-done-retracting' callback. +Span deletion property set to flag DELETE-REGION." + (let ((span (make-span start end))) + (set-span-property span 'delete-me delete-region) + (list (list span proof-command 'proof-done-retracting)))) + + +(defun proof-last-goal-or-goalsave () + (save-excursion + (let ((span (span-at-before (proof-locked-end) 'type))) + (while (and span + (not (eq (span-property span 'type) 'goalsave)) + (or (eq (span-property span 'type) 'proof) + (eq (span-property span 'type) 'comment) + (not (funcall proof-goal-command-p + (span-property span 'cmd))))) + (setq span (prev-span span 'type))) + span))) + +;; +;; NB: Should carefully explain/document this behaviour somewhere. +;; The undo is three-phase: +;; undo-cmd - ... - undo-cmd within proof +;; kill proof exit proof +;; forget-to-declaration forget target span +;; +;; It turns out that this behaviour is not quite right for Coq. +;; It might be simpler to just use a single undo/forget +;; command, which is called in all cases. +;; +(defun proof-retract-target (target delete-region) + "Retract the span TARGET and delete it if DELETE-REGION is non-nil. +Notice that this necessitates retracting any spans following TARGET, +up to the end of the locked region." + (let ((end (proof-unprocessed-begin)) + (start (span-start target)) + (span (proof-last-goal-or-goalsave)) + actions) + + ;; NB: first section only entered if proof-kill-goal-command is + ;; non-nill. Otherwise we expect proof-find-and-forget-fn to do + ;; all relevent work for arbitrary retractions. FIXME: clean up + + ;; Examine the last span in the locked region. + + ;; If the last goal or save span is not a proof or + ;; prover processed file, we examine to see how to remove it. + (if (and span proof-kill-goal-command + (not (or + (memq (span-property span 'type) + '(goalsave proverproc))))) + ;; If the goal or goalsave span ends before the target span, + ;; then we are retracting within the last unclosed proof, + ;; and the retraction just amounts to a number of undo + ;; steps. + ;; FIXME: really, there shouldn't be more work to do: so + ;; why call proof-find-and-forget-fn later? + (if (< (span-end span) (span-end target)) + (progn + ;; Skip comment spans at and immediately following target + (setq span target) + (while (and span (eq (span-property span 'type) 'comment)) + (setq span (next-span span 'type))) + ;; Calculate undos for the current open segment + ;; of proof commands + (setq actions (proof-setup-retract-action + start end + (if (null span) proof-no-command + (funcall proof-count-undos-fn span)) + delete-region) + end start)) + ;; Otherwise, start the retraction by killing off the + ;; currently active goal. + ;; FIXME: and couldn't we move the end upwards? + ;; FIXME: hack proof-nesting-depth here. This is + ;; in the wrong place: it should be done *after* the + ;; retraction has succeeded. + (setq proof-nesting-depth (1- proof-nesting-depth)) + (setq actions + (proof-setup-retract-action (span-start span) end + proof-kill-goal-command + delete-region) + end (span-start span)))) + ;; Check the start of the target span lies before the end + ;; of the locked region (should always be true since we don't + ;; make spans outside the locked region at the moment)... + ;; But end may have moved backwards above: this just checks whether + ;; there is more retraction to be done. + (if (> end start) + (setq actions + ;; Append a retract action to clear the entire + ;; start-end region. Rely on proof-find-and-forget-fn + ;; to calculate a command which "forgets" back to + ;; the first definition, declaration, or whatever + ;; that comes after the target span. + ;; FIXME: originally this assumed a linear context, + ;; and that forgetting the first thing forgets all + ;; subsequent ones. it might be more general to + ;; allow *several* commands, and even queue these + ;; separately for each of the spans following target + ;; which are concerned. + (nconc actions (proof-setup-retract-action + start end + (funcall proof-find-and-forget-fn target) + delete-region)))) + + (proof-start-queue (min start end) (proof-locked-end) actions))) + +;; FIXME da: I would rather that this function moved point to +;; the start of the region retracted? + +;; FIXME da: Maybe retraction to the start of +;; a file should remove it from the list of included files? +;; NB: the "interactive" variant is so that we get a simple docstring. +(defun proof-retract-until-point-interactive (&optional delete-region) + "Tell the proof process to retract until point. +If invoked outside a locked region, undo the last successfully processed +command. If called with a prefix argument (DELETE-REGION non-nil), also +delete the retracted region from the proof-script." + (interactive "P") + (proof-retract-until-point delete-region)) + +(defun proof-retract-until-point (&optional delete-region) + "Set up the proof process for retracting until point. +In particular, set a flag for the filter process to call +`proof-done-retracting' after the proof process has successfully +reset its state. +If DELETE-REGION is non-nil, delete the region in the proof script +corresponding to the proof command sequence. +If invoked outside a locked region, undo the last successfully processed +command." + (if (proof-locked-region-empty-p) + (error "No locked region") + ;; Make sure we're ready: either not busy, or already advancing/retracting. + ;;(proof-activate-scripting nil '(advancing retracting)) + (proof-activate-scripting) + (let ((span (span-at (point) 'type))) + ;; If no span at point, retracts the last span in the buffer. + (unless span + (proof-goto-end-of-locked) + (backward-char) + (setq span (span-at (point) 'type))) + (proof-retract-target span delete-region)))) + + + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Proof General scripting mode definition, part 1. +;; + +(eval-and-compile ; to define vars +;;; NB: autoload tag below doesn't work for d-d-m, autoload is in proof.el +;;;###autoload +(define-derived-mode proof-mode fundamental-mode + proof-general-name + "Proof General major mode class for proof scripts. +\\{proof-mode-map}" + + (setq proof-buffer-type 'script) + + ;; font-lock-keywords isn't automatically buffer-local in Emacs 21.2 + (make-local-variable 'font-lock-keywords) + + ;; During write-file it can happen that we re-set the mode for + ;; the currently active scripting buffer. The user might also + ;; do this for some reason. We could maybe let + ;; this pass through, but it seems safest to treat it as + ;; a kill buffer operation (retract and clear spans). + ;; (NB: other situations seem to cause double successive calls to + ;; proof-mode). + (if (eq (current-buffer) proof-script-buffer) + (proof-script-kill-buffer-fn)) + + ;; We set hook functions here rather than in proof-config-done so + ;; that they can be adjusted by prover specific code if need be. + (proof-script-set-buffer-hooks) + + (make-local-hook 'after-set-visited-file-name-hooks) + (add-hook 'after-set-visited-file-name-hooks 'proof-script-set-visited-file-name)) + + (make-local-hook 'proof-activate-scripting-hook) + (add-hook 'proof-activate-scripting-hook 'proof-cd-sync nil t)) + +;; NB: proof-mode-map declared by define-derived-mode above +(proof-menu-define-keys proof-mode-map) + +(defun proof-script-set-visited-file-name () + "Called when visited file name is changed. + +This is a hook function for `after-set-visited-file-name-hooks'. + +For some provers, the file from which script commands are being +processed may be important, and if it is changed with C-x C-w, for +example, we might have to retract the contents or inform the proof +assistant of the new name. This should be done by adding +additional functions to `after-set-visited-file-name-hooks'. + +At the least, we need to set the buffer local hooks again +with `proof-script-set-buffer-hooks' which is what this function does, +as well as setting `proof-script-buffer-file-name' (which see). + +This hook also gives a warning in case this is the active scripting buffer." + (setq proof-script-buffer-file-true buffer-file-name) + (if (eq (current-buffer) proof-script-buffer) + (proof-warning +"Active scripting buffer changed name; synchronization risked if prover tracks filenames!")) + (proof-script-set-buffer-hooks)) + + + +(defun proof-script-set-buffer-hooks () + "Set the hooks for a proof script buffer. +The hooks set here are cleared by write-file, so we use this function +to restore them using `after-set-visited-file-name-hooks'." + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'proof-script-kill-buffer-fn t t) + ;; Reverting buffer is same as killing it as far as PG is concerned + (make-local-hook 'before-revert-hook) + (add-hook 'before-revert-hook 'proof-script-kill-buffer-fn t t)) + +(defun proof-script-kill-buffer-fn () + "Value of kill-buffer-hook for proof script buffers. +Clean up before a script buffer is killed. +If killing the active scripting buffer, run proof-deactivate-scripting-auto. +Otherwise just do proof-restart-buffers to delete some spans from memory." + ;; Deactivate scripting in the current buffer if need be, forcing + ;; automatic retraction if the buffer is not fully processed. + (if (eq (current-buffer) proof-script-buffer) + (proof-deactivate-scripting-auto)) + (proof-restart-buffers (list (current-buffer))) + ;; Hide away goals, response, and tracing. This is a hack because + ;; otherwise we can lead the user to frustration with the + ;; dedicated windows nonsense. + (proof-map-buffers + (list proof-goals-buffer proof-response-buffer proof-trace-buffer) + (bury-buffer (current-buffer)))) + + +;; Notes about how to deal with killing/reverting/renaming buffers: +;; (As of XEmacs 21.1.9, see files.el) +;; +;; Killing: easy, set kill-buffer-hook +;; Reverting: ditto, set before-revert-hook to do same as kill. +;; Renaming (write-file): much tricker. Code for write-file does +;; several odd things. It kills off local hook functions, calls +;; `after-set-visited-file-name-hooks' right at the end to give the +;; chance to restore them, but then tends to automatically (re-)set +;; the mode anyway. + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Proof General scripting mode definition - part 2 +;; + +;; The functions proof-config-done[-related] are called after the +;; derived mode has made its settings. + +;; The callback *-config-done mechanism is an irritating hack - there +;; should be some elegant mechanism for computing constants after the +;; child has configured. Should petition the author of "derived-mode" +;; about this! + +(defun proof-config-done-related () + "Finish setup of Proof General scripting and related modes. +This is a subroutine of `proof-config-done'. + +This is intended for proof assistant buffers which are similar to +script buffers, but for which scripting is not enabled. In +particular, we: lock the buffer if it appears on +`proof-included-files-list'; configure font-lock support from +`font-lock-keywords'; maybe turn on X-Symbol minor mode. + +This is used for Isabelle theory files, which share some scripting +mode features, but are only ever processed atomically by the proof +assistant." + (setq proof-script-buffer-file-name buffer-file-name) + + ;; Has buffer already been processed? + ;; NB: call to file-truename is needed for GNU Emacs which + ;; chooses to make buffer-file-truename abbreviate-file-name + ;; form of file-truename. + (and buffer-file-truename + (member (file-truename buffer-file-truename) + proof-included-files-list) + (proof-complete-buffer-atomic (current-buffer))) + + ;; calculate some strings and regexps for searching + (setq proof-terminal-string + (if proof-terminal-char + (char-to-string proof-terminal-char) + "")) + + (make-local-variable 'comment-start) + (setq comment-start (concat proof-script-comment-start " ")) + (make-local-variable 'comment-end) + (setq comment-end (concat " " proof-script-comment-end)) + + (unless proof-script-comment-start-regexp + (setq proof-script-comment-start-regexp (regexp-quote proof-script-comment-start))) + (unless proof-script-comment-end-regexp + (setq proof-script-comment-end-regexp (regexp-quote proof-script-comment-end))) + + (make-local-variable 'comment-start-skip) + (setq comment-start-skip + (concat proof-script-comment-start-regexp "+\\s_?")) + + ;; + ;; Fontlock support. + ;; + ;; Assume font-lock case folding follows proof-case-fold-search + (proof-font-lock-configure-defaults 'autofontify proof-case-fold-search) + + ;; Maybe turn on x-symbol mode. + (proof-x-symbol-mode)) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Generic defaults for hooks, based on regexps. +;; + +;; The next step is to use proof-stringfn-match scheme more widely, to +;; allow settings which are string or fn, so we don't need both regexp +;; and function hooks, and so that the other hooks can be functions too. + +(defun proof-generic-goal-command-p (str) + "Is STR a goal? Decide by matching with proof-goal-command-regexp." + (proof-string-match-safe proof-goal-command-regexp str)) + +(defun proof-generic-state-preserving-p (cmd) + "Is CMD state preserving? Match on proof-non-undoables-regexp." + ;; FIXME: logic here is not quite finished: proof-non-undoables are + ;; certainly not state preserving, but so are a bunch more things, + ;; i.e. ordinary proof commands which may appear in proof scripts. + ;; Might be better to add positive and negative regexps for + ;; state-preserving tests (only one of which needs to be set). + (not (proof-string-match-safe proof-non-undoables-regexp cmd))) + +(defun proof-generic-count-undos (span) + "Count number of undos in a span, return command needed to undo that far. +Command is set using `proof-undo-n-times-cmd'. + +A default value for `proof-count-undos-fn'. + +For this function to work properly, you must configure +`proof-undo-n-times-cmd' and `proof-ignore-for-undo-count'." + (let + ((case-fold-search proof-case-fold-search) + (ct 0) str i) + (while span + (setq str (span-property span 'cmd)) + (cond ((eq (span-property span 'type) 'vanilla) + (unless (proof-stringfn-match proof-ignore-for-undo-count str) + (incf ct))) + ((eq (span-property span 'type) 'pbp) + (setq i 0) + (while (< i (length str)) + (if (= (aref str i) proof-terminal-char) (incf ct)) + (incf i)))) + (setq span (next-span span 'type))) + (if (= ct 0) + proof-no-command + (cond ((stringp proof-undo-n-times-cmd) + (format proof-undo-n-times-cmd ct)) + ((functionp proof-undo-n-times-cmd) + (funcall proof-undo-n-times-cmd ct)))))) + +(defun proof-generic-find-and-forget (span) + "Calculate a forget/undo command to forget back to SPAN. +This is a long-range forget: we know that there is no +open goal at the moment, so forgetting involves unbinding +declarations, etc, rather than undoing proof steps. + +This generic implementation assumes it is enough to find the +nearest following span with a `name' property, and retract +that using `proof-forget-id-command' with the given name. + +If this behaviour is not correct, you must customize the function +with something different." + ;; Modelled on Isar's find-and-forget function, but less + ;; general at the moment: will only issue one und command. + ;; FIXME: would be much cleaner to wrap up the undo behaviour + ;; also within proofs in this function. + (let (str ans typ name answers) + (while span + (setq ans nil) + (setq str (span-property span 'cmd)) + (setq typ (span-property span 'type)) + (cond + ;; comment, diagnostic, nested proof command: skip + ((or (eq typ 'comment) + (eq typ 'proof) + (and proof-ignore-for-undo-count cmd + (proof-string-match proof-ignore-for-undo-count cmd)))) + ;; some named element: use generic forget-id function; finish. + ((setq name (span-property span 'name)) + (setq ans (format proof-forget-id-command name)) + (setq span nil))) + (if ans (setq answers (cons ans answers))) + (if span (setq span (next-span span 'type)))) + (if (null answers) proof-no-command (apply 'concat answers)))) + +;; +;; End of new generic functions +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; +;; Sanity checks on important settings +;; + +(defconst proof-script-important-settings + '(proof-script-comment-start ; + proof-script-comment-end + proof-save-command-regexp +; proof-goal-command-regexp ; not needed if proof-goal-command-p is set +; proof-goal-with-hole-regexp ; non-essential? +; proof-save-with-hole-regexp ; non-essential? +; proof-showproof-command ; non-essential +; proof-goal-command ; non-essential +; proof-save-command ; do +; proof-kill-goal-command ; do + )) + +(defun proof-config-done () + "Finish setup of Proof General scripting mode. +Call this function in the derived mode for the proof assistant to +finish setup which depends on specific proof assistant configuration." + + (proof-config-done-related) + + ;; Following group of settings only relevant if the current + ;; buffer is really a scripting buffer. Isabelle Proof General + ;; has theory file buffers which share some aspects, they + ;; just use proof-config-done-related. + + ;; Preamble: make this mode class "pg-sticky" so that renaming file + ;; to something different doesn't change the mode, no matter what + ;; the filename. This is a hack so that write-file will work: + ;; otherwise Emacs insists (as of XEmacs 21.1.9 at least) on + ;; re-setting the mode, which leads to problems with synchronization + ;; and losing extents. (Attempt to catch this in proof-mode by + ;; looking for active scripting buffer fails; perhaps because of + ;; kill buffer function) + (put major-mode 'mode-class 'pg-sticky) + + ;; First, define some values if they aren't defined already. + (unless proof-mode-for-script + (setq proof-mode-for-script major-mode)) + + (if (and proof-non-undoables-regexp + (not proof-ignore-for-undo-count)) + (setq proof-ignore-for-undo-count + proof-non-undoables-regexp)) + + ;; Give warnings if some crucial settings haven't been made + (dolist (sym proof-script-important-settings) + (proof-warn-if-unset "proof-config-done" sym)) + + ;; Additional key definitions which depend on configuration for + ;; specific proof assistant. + ;; FIXME da: generalize here. Might have electric terminator for + ;; other parsing mechanisms too, using new proof-script-parse-function + ;; Could use a default terminal char + (if proof-terminal-char + (progn + (define-key proof-mode-map + (vconcat [(control c)] (vector proof-terminal-char)) + 'proof-electric-terminator-toggle) + (define-key proof-mode-map (vector proof-terminal-char) + 'proof-electric-terminator))) + ;; It's ugly, but every script buffer has a local copy changed in + ;; sync by the fn proof-electric-terminator-enable + (setq proof-electric-terminator proof-electric-terminator-enable) + + (make-local-variable 'indent-line-function) + (setq indent-line-function 'proof-indent-line) + + ;; Toolbar and scripting menu + ;; NB: autloads proof-toolbar, which defines proof-toolbar-scripting-menu. + (proof-toolbar-setup) + + ;; Menus: the Proof-General and the specific menu + (proof-menu-define-main) + (proof-menu-define-specific) + (easy-menu-add proof-mode-menu proof-mode-map) + (easy-menu-add proof-assistant-menu proof-mode-map) + + ;; Choose parsing mechanism according to different kinds of script syntax. + ;; Choice of function depends on configuration setting. + (unless (fboundp 'proof-segment-up-to) + (if proof-script-use-old-parser + ;; Configuration for using old parsing mechanism. + (cond + (proof-script-parse-function ;; still allowed to override in 3.2 + (defalias 'proof-segment-up-to 'proof-segment-up-to-parser)) + ;; 3.2 mechanism here + (proof-script-command-start-regexp + (defalias 'proof-segment-up-to 'proof-segment-up-to-cmdstart)) + (t + (defalias 'proof-segment-up-to 'proof-segment-up-to-cmdend) + (unless proof-script-command-end-regexp + (proof-warn-if-unset "proof-config-done" 'proof-terminal-char) + (setq proof-script-command-end-regexp + (if proof-terminal-char + (regexp-quote (char-to-string proof-terminal-char)) + "$"))))) + ;; Configuration for using new parsing (3.3 and later; default in 3.5) + (progn + (defalias 'proof-segment-up-to 'proof-segment-up-to-parser) + (cond + (proof-script-parse-function + ;; already set, nothing to do + ) + (proof-script-sexp-commands + (setq proof-script-parse-function 'proof-script-generic-parse-sexp)) + (proof-script-command-start-regexp + (setq proof-script-parse-function 'proof-script-generic-parse-cmdstart)) + ((or proof-script-command-end-regexp proof-terminal-char) + (setq proof-script-parse-function 'proof-script-generic-parse-cmdend) + (unless proof-script-command-end-regexp + (proof-warn-if-unset "probof-config-done" 'proof-terminal-char) + (setq proof-script-command-end-regexp + (if proof-terminal-char + (regexp-quote (char-to-string proof-terminal-char)) + "$")))) + (t + (error "Configuration error: must set `proof-terminal-char' or one of its friends")))) + )) ; default if nothing set is EOL. + + ;; Setup a default for imenu. + (unless (and (boundp 'imenu-generic-expression) + imenu-generic-expression) + (set (make-local-variable 'imenu-generic-expression) + (delq nil + (list + (if proof-goal-with-hole-regexp + (list nil proof-goal-with-hole-regexp + proof-goal-with-hole-result)) + (if proof-save-with-hole-regexp + (list "Saves" proof-save-with-hole-regexp + proof-save-with-hole-result)))))) + + ;; Make sure func menu is configured. (NB: Ideal place for this and + ;; similar stuff would be in something evaluated at top level after + ;; defining the derived mode: normally we wouldn't repeat this + ;; each time the mode function is run, so we wouldn't need "pushnew"). + + (cond ((proof-try-require 'func-menu) + ;; FIXME: we'd like to let the library load later, but + ;; it's a bit tricky: this stuff doesn't seem to work + ;; in an eval-after-load body (local vars?). + (unless proof-script-next-entity-regexps ; unless already set + ;; Try to calculate a useful default value. + ;; FIXME: this is rather complicated! The use of the regexp + ;; variables needs sorting out. + (customize-set-variable + 'proof-script-next-entity-regexps + (let ((goal-discrim + ;; Goal discriminator searches forward for matching + ;; save if the regexp is set. + (if proof-goal-with-hole-regexp + (if proof-save-command-regexp + (list + proof-goal-with-hole-regexp 2 + 'forward proof-save-command-regexp) + (list proof-goal-with-hole-regexp 2)))) + ;; Save discriminator searches backward for matching + ;; goal if the regexp is set. + (save-discrim + (if proof-save-with-hole-regexp + (if proof-goal-command-regexp + (list + proof-save-with-hole-regexp 2 + 'backward proof-goal-command-regexp) + (list proof-save-with-hole-regexp 2))))) + (cond + ((and proof-goal-with-hole-regexp proof-save-with-hole-regexp) + (list + (proof-regexp-alt + proof-goal-with-hole-regexp + proof-save-with-hole-regexp) goal-discrim save-discrim)) + + (proof-goal-with-hole-regexp + (list proof-goal-with-hole-regexp goal-discrim)) + + (proof-save-with-hole-regexp + (list proof-save-with-hole-regexp save-discrim)))))) + + (if proof-script-next-entity-regexps + ;; Enable func-menu for this mode if regexps set now + (progn + (pushnew + (cons major-mode 'proof-script-next-entity-regexps) + fume-function-name-regexp-alist) + (pushnew + (cons major-mode proof-script-find-next-entity-fn) + fume-find-function-name-method-alist))))) + + ;; Offer to save script mode buffers which have no files, + ;; in case Emacs is exited accidently. + (or (buffer-file-name) + (setq buffer-offer-save t)) + + ;; Localise the invisibility glyph (XEmacs only): + (let ((img (proof-get-image "hiddenproof" t nil))) + (cond + ((and img proof-running-on-XEmacs) + (set-glyph-image invisible-text-glyph img (current-buffer))))) + + ;; To begin with, make everything visible in the buffer + ;; (FIXME: this is done via proof-init-segmentation, now, + ;; when is that called?) + (setq buffer-invisibility-spec nil) + + ;; Finally, make sure the user has been welcomed! + ;; [NB: this doesn't work well, gets zapped by loading messages] + (proof-splash-message)) + + +(provide 'proof-script) +;; proof-script.el ends here. diff --git a/generic/proof-shell.el b/generic/proof-shell.el new file mode 100644 index 00000000..3f2e2e6a --- /dev/null +++ b/generic/proof-shell.el @@ -0,0 +1,1901 @@ +;; proof-shell.el Proof General shell mode. +;; +;; Copyright (C) 1994-2002 LFCS Edinburgh. +;; Authors: David Aspinall, Yves Bertot, Healfdene Goguen, +;; Thomas Kleymann and Dilip Sequeira +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; + +(require 'proof-menu) +(require 'span) +(require 'pg-goals) ; associated output +(require 'pg-response) ; buffers for goals/response + +;; Nuke some byte compiler warnings. + +(eval-when-compile + (require 'comint) + (require 'font-lock)) + + +;; FIXME: +;; Autoloads for proof-script (added to nuke warnings, +;; maybe should be 'official' exported functions in proof.el) +;; This helps see interface between proof-script / proof-shell. +;; FIXME 2: We can probably assume that proof-script is always +;; loaded before proof-shell, so just put a require on +;; proof-script here. +(eval-and-compile + (mapcar (lambda (f) + (autoload f "proof-script")) + '(proof-goto-end-of-locked + proof-insert-pbp-command + proof-detach-queue + proof-locked-end + proof-set-queue-endpoints + proof-script-clear-queue-spans + proof-file-to-buffer + proof-register-possibly-new-processed-file + proof-restart-buffers))) + +;; FIXME: +;; Some variables from proof-shell are also used, in particular, +;; the menus. These should probably be moved out to proof-menu. + +;; ============================================================ +;; +;; Internal variables used by proof shell +;; + +(defvar proof-marker nil + "Marker in proof shell buffer pointing to previous command input.") + +(defvar proof-action-list nil + "A list of + + (SPAN COMMAND ACTION) + +triples, which is a queue of things to do. +See the functions `proof-start-queue' and `proof-exec-loop'.") + +(defvar proof-shell-silent nil + "A flag, non-nil if PG thinks the prover is silent.") + +;; not implemented +;;(defvar proof-step-counter nil +;; "Contains a proof step counter, which counts `outputful' steps.") + + +;; We keep a record of the last output from the proof system and a +;; flag indicating its type, as well as a previous ("delayed") to use +;; when the end of the queue is reached or an error or interrupt +;; occurs. + +;; A raw record of the last prompt from the proof system +(defvar proof-shell-last-prompt nil + "A record of the last prompt seen from the proof system. +This is the string matched by `proof-shell-annotated-prompt-regexp'.") + +;; A raw record of the last output from the proof system +(defvar proof-shell-last-output nil + "A record of the last string seen from the proof system.") + +;; A flag indicating the type of thing proof-shell-last-output +(defvar proof-shell-last-output-kind nil + "A symbol denoting the type of the last output string from the proof system. +Specifically: + + 'interrupt An interrupt message + 'error An error message + 'abort A proof abort message + 'loopback A command sent from the PA to be inserted into the script + 'response A response message + 'goals A goals (proof state) display + 'systemspecific Something specific to a particular system, + -- see `proof-shell-process-output-system-specific' + +The output corresponding to this will be in proof-shell-last-output. + +See also `proof-shell-proof-completed' for further information about +the proof process output, when ends of proofs are spotted. + +This variable can be used for instance specific functions which want +to examine proof-shell-last-output.") + +(defvar proof-shell-delayed-output nil + "A copy of proof-shell-last-output held back for processing at end of queue.") + +(defvar proof-shell-delayed-output-kind nil + "A copy of proof-shell-last-output-lind held back for processing at end of queue.") + + + +;; +;; Implementing the process lock +;; +;; da: In fact, there is little need for a lock. Since Emacs Lisp +;; code is single-threaded, a loop parsing process output cannot get +;; pre-empted by the user trying to send more input to the process, +;; or by the process filter trying to deal with more output. +;; (Moreover, we can tell when the process is busy because the +;; queue is non-empty). +;; +;; + +;; +;; We have two functions: +;; +;; proof-shell-ready-prover +;; starts proof shell, gives error if it's busy. +;; +;; proof-activate-scripting (in proof-script.el) +;; calls proof-shell-ready-prover, and turns on scripting minor +;; mode for current (scripting) buffer. +;; +;; Also, a new enabler predicate: +;; +;; proof-shell-available +;; returns non-nil if a proof shell is active and not locked. +;; +;; Maybe proof-shell-ready-prover doesn't need to start the shell? +;; + +;;;###autoload +(defun proof-shell-ready-prover (&optional queuemode) + "Make sure the proof assistant is ready for a command. +If QUEUEMODE is set, succeed if the proof shell is busy but +has mode QUEUEMODE, which is a symbol or list of symbols. +Otherwise, if the shell is busy, give an error. +No change to current buffer or point." + (proof-shell-start) + (unless (or (not proof-shell-busy) + (eq queuemode proof-shell-busy) + (member proof-shell-busy queuemode)) + (error "Proof Process Busy!"))) + +;;;###autoload +(defun proof-shell-live-buffer () + "Return buffer of active proof assistant, or nil if none running." + (and proof-shell-buffer + (buffer-live-p proof-shell-buffer) + (comint-check-proc proof-shell-buffer))) + +;;;###autoload +(defun proof-shell-available-p () + "Returns non-nil if there is a proof shell active and available. +No error messages. Useful as menu or toolbar enabler." + (and (proof-shell-live-buffer) + (not proof-shell-busy))) + +(defun proof-grab-lock (&optional queuemode) + "Grab the proof shell lock, starting the proof assistant if need be. +Runs `proof-state-change-hook' to notify state change. +Clears the `proof-shell-error-or-interrupt-seen' flag. +If QUEUEMODE is supplied, set the lock to that value." + (proof-shell-ready-prover queuemode) + (setq proof-shell-error-or-interrupt-seen nil) + (setq proof-shell-busy (or queuemode t)) + (run-hooks 'proof-state-change-hook)) + +(defun proof-release-lock (&optional err-or-int) + "Release the proof shell lock, with error or interrupt flag ERR-OR-INT. +Clear `proof-shell-busy', and set `proof-shell-error-or-interrupt-seen' +to err-or-int." + (setq proof-shell-error-or-interrupt-seen err-or-int) + (setq proof-shell-busy nil)) + + + +;; +;; Starting and stopping the proof shell +;; + +(defun proof-shell-start () + "Initialise a shell-like buffer for a proof assistant. + +Also generates goal and response buffers. +Does nothing if proof assistant is already running." + (interactive) + (unless (proof-shell-live-buffer) + + ;; This should configure the mode-setting variables + ;; proof-mode-for-<blah> so we can set the modes below. + ;; <blah>=shell,goals,response. We also need to set + ;; proof-prog-name to start the program! + (run-hooks 'proof-pre-shell-start-hook) + + ;; Clear some state [ fixme: should clear more? ] + (setq proof-included-files-list nil) + + ;; Added 05/99 by Patrick L. + (let ((name (buffer-file-name (current-buffer)))) + ;; FIXME : we check that the buffer corresponds to a file, + ;; but we do not check that it is in coq- or isa-mode + (if (and name proof-prog-name-guess proof-guess-command-line) + (setq proof-prog-name + (apply proof-guess-command-line (list name))))) + + (if proof-prog-name-ask + (save-excursion + (setq proof-prog-name (read-shell-command "Run process: " + proof-prog-name)))) + (let + ;; PG 3.1: Buffer names are now based simply on proof assistant + ;; name, not process name which was a bit lowlevel and sometimes + ;; ugly (coqtop, hol.unquote). + ((proc (downcase proof-assistant))) + + (message "Starting process: %s" proof-prog-name) + + ;; Starting the inferior process (asynchronous) + (let ((prog-name-list + (proof-string-to-list + ;; Cut in proof-rsh-command if it's non-nil and + ;; non whitespace. FIXME: whitespace at start + ;; of this string is nasty. + (if (and proof-rsh-command + (not (string-match "^[ \t]*$" proof-rsh-command))) + (concat proof-rsh-command " " proof-prog-name) + proof-prog-name) + ;; Split on spaces: FIXME: maybe should be whitespace. + " ")) + + (process-connection-type + proof-shell-process-connection-type) + + ;; PG 3.5: adjust the LANG variable to remove UTF-8 + ;; encoding that may be there. This fix is targeted at RH + ;; 8 which has glibc 2.2, unicode encoding by default. + ;; FIXME: unfortunately this fix doesn't work; it's + ;; not enough to alter process-environment to effect + ;; a locale change. In bash, LANG=x <prog> works though. + (process-environment + (if (not proof-shell-wakeup-char) ;; if specials not used, + process-environment ;; leave it alone + (if (getenv "LANG") + (setenv + "LANG" + (replace-in-string (getenv "LANG") + "\\.UTF-8" ""))) + process-environment))) + + ;; An improvement here might be to catch failure of + ;; make-comint and then kill off the buffer. Then we + ;; could add back code above for multiple shells <2> <3>, etc. + ;; Seems hardly worth it. + (apply 'make-comint (append (list proc (car prog-name-list) nil) + (cdr prog-name-list)))) + + (setq proof-shell-buffer (get-buffer (concat "*" proc "*"))) + + (unless (proof-shell-live-buffer) + ;; Give error now if shell buffer isn't live + ;; Solves problem of make-comint succeeding but process + ;; exiting immediately. + ;; Might still be problems here if sentinels are set. + (setq proof-shell-buffer nil) + (error "Starting process: %s..failed" proof-prog-name)) + + ;; FIXME: patch to go in here to clean this up + ;; Create the associated buffers and set buffer variables + (let ((goals (concat "*" proc "-goals*")) + (resp (concat "*" proc "-response*")) + (trace (concat "*" proc "-trace*")) + (thms (concat "*" proc "-thms*"))) + (setq proof-goals-buffer (get-buffer-create goals)) + (setq proof-response-buffer (get-buffer-create resp)) + (if proof-shell-trace-output-regexp + (setq proof-trace-buffer (get-buffer-create trace))) + (if proof-shell-thms-output-regexp + (setq proof-thms-buffer (get-buffer-create thms))) + ;; Set the special-display-regexps now we have the buffer names + (setq proof-shell-special-display-regexp + (proof-regexp-alt goals resp trace thms)) + (proof-multiple-frames-enable)) + + (save-excursion + (set-buffer proof-shell-buffer) + + ;; clear output from previous sessions. + (erase-buffer) + + ;; Disable multi-byte characters in GNU Emacs. + ;; We noticed that for LEGO, it otherwise converts annotations + ;; to characters with (non-ASCII) code around 3000 which screws + ;; up our conventions that annotations lie between 128 and 256. + ;; + (and (fboundp 'toggle-enable-multibyte-characters) + (toggle-enable-multibyte-characters -1)) + + ;; Initialise shell mode + ;; Q: should this be done every time the process is started? + ;; A: yes, it does the process initialization, which is a bit + ;; odd (would expect it to be done here, maybe). + (funcall proof-mode-for-shell) + + ;; Check to see that the process is still going. + ;; Otherwise the sentinel will have killed off the + ;; other buffers and there's no point initialising + ;; them. + (if (proof-shell-live-buffer) + (progn + ;; Set mode for response buffer + (set-buffer proof-response-buffer) + (funcall proof-mode-for-response) + ;; Set mode for trace buffer + (proof-with-current-buffer-if-exists proof-trace-buffer + (funcall proof-mode-for-response)) + ;; Set mode for goals buffer + (set-buffer proof-goals-buffer) + (and (fboundp 'toggle-enable-multibyte-characters) + (toggle-enable-multibyte-characters -1)) + (funcall proof-mode-for-goals)) + ;; + ;; If the process died, switch to the buffer to + ;; display the error messages to the user. + (switch-to-buffer proof-shell-buffer) + (error "%s process exited!" proc))) + + (message "Starting %s process... done." proc)))) + + +;; +;; Indicator and fake minor mode for active scripting buffer +;; + +(defcustom proof-shell-active-scripting-indicator + (if proof-running-on-XEmacs + (cons (make-extent nil nil) " Scripting ") + " Scripting") + "Modeline indicator for active scripting buffer. +If first component is extent it will automatically follow the colour +of the queue region." + :type 'sexp + :group 'proof-general-internals) + +(cond + (proof-running-on-XEmacs + (if (extentp (car proof-shell-active-scripting-indicator)) + (set-extent-properties + (car proof-shell-active-scripting-indicator) + '(face proof-locked-face))))) + +(unless + (assq 'proof-active-buffer-fake-minor-mode minor-mode-alist) + (setq minor-mode-alist + (append minor-mode-alist + (list + (list + 'proof-active-buffer-fake-minor-mode + proof-shell-active-scripting-indicator))))) + + +;; +;; Shutting down proof shell and associated buffers +;; + +;; Hooks here are handy for liaising with prover config stuff. + +(defvar proof-shell-kill-function-hooks nil + "Functions run from proof-shell-kill-function.") + +(defun proof-shell-kill-function () + "Function run when a proof-shell buffer is killed. +Attempt to shut down the proof process nicely and +clear up all the locked regions and state variables. +Value for `kill-buffer-hook' in shell buffer. +Also called by `proof-shell-bail-out' if the process is +exited by hand (or exits by itself)." + (let* ((alive (comint-check-proc (current-buffer))) + (proc (get-buffer-process (current-buffer))) + (bufname (buffer-name))) + (message "%s, cleaning up and exiting..." bufname) + (let ((inhibit-quit t) ; disable C-g for now + timeout-id) + (sit-for 0) ; redisplay [does it work?] + (if alive ; process still there + (progn + (catch 'exited + (set-process-sentinel proc + (lambda (p m) (throw 'exited t))) + ;; First, turn off scripting in any active scripting + ;; buffer. (This helps support persistent sessions with + ;; Isabelle, for example, by making sure that no file is + ;; partly processed when exiting, and registering completed + ;; files). + (proof-deactivate-scripting-auto) + ;; FIXME: if the shell is busy now, we should wait + ;; for a while (in case deactivate causes processing) + ;; and the send an interrupt. + + ;; Second, we try to shut down the proof process + ;; politely. Do this before deleting other buffers, + ;; etc, so that any closing down processing works okay. + (if proof-shell-quit-cmd + (comint-send-string proc + (concat proof-shell-quit-cmd "\n")) + (comint-send-eof)) + ;; Wait a while for it to die before killing + ;; it off more rudely. In XEmacs, accept-process-output + ;; or sit-for will run process sentinels if a process + ;; changes state. + ;; In FSF I've no idea how to get the process sentinel + ;; to run outside the top-level loop. + ;; So put an ugly timeout and busy wait here instead + ;; of simply (accept-process-output nil 10). + (setq timeout-id + (add-timeout + proof-shell-quit-timeout + (lambda (&rest args) + (if (comint-check-proc (current-buffer)) + (kill-process (get-buffer-process + (current-buffer)))) + (throw 'exited t)) nil)) + (while (comint-check-proc (current-buffer)) + ;; Perhaps XEmacs hangs too, lets try both wait forms. + (accept-process-output nil 1) + (sit-for 1))) + ;; Disable timeout and sentinel in case one or + ;; other hasn't signalled yet, but we're here anyway. + (disable-timeout timeout-id) + ;; FIXME: this was added to fix 'No catch for exited tag' + ;; problem, but it's done later below anyway? + (set-process-sentinel proc nil))) + (if (comint-check-proc (current-buffer)) + (proof-debug + "Error in proof-shell-kill-function: process still lives!")) + ;; For FSF Emacs, proc may be nil if killed already. + (if proc (set-process-sentinel proc nil)) + ;; Restart all scripting buffers + (proof-script-remove-all-spans-and-deactivate) + ;; Clear state + (proof-shell-clear-state) + ;; Run hooks + (run-hooks 'proof-shell-kill-function-hooks) + ;; Kill buffers associated with shell buffer + (let ((proof-shell-buffer nil)) ;; fool kill buffer hooks + (dolist (buf '(proof-goals-buffer proof-response-buffer + proof-trace-buffer)) + (if (buffer-live-p (eval buf)) + (progn + (kill-buffer (eval buf)) + (set buf nil))))) + (message "%s exited." bufname)))) + +(defun proof-shell-clear-state () + "Clear internal state of proof shell." + (setq proof-action-list nil + proof-included-files-list nil + proof-shell-busy nil + proof-shell-proof-completed nil + proof-nesting-depth 0 + proof-shell-error-or-interrupt-seen nil + proof-shell-silent nil + proof-shell-last-output nil + proof-shell-last-output-kind nil + proof-shell-last-prompt nil + proof-shell-delayed-output nil + proof-shell-delayed-output-kind nil)) + +(defun proof-shell-exit () + "Query the user and exit the proof process. + +This simply kills the `proof-shell-buffer' relying on the hook function +`proof-shell-kill-function' to do the hard work." + (interactive) + (if (buffer-live-p proof-shell-buffer) + (if (yes-or-no-p (format "Exit %s process? " proof-assistant)) + (progn (kill-buffer proof-shell-buffer) + (setq proof-shell-buffer nil)) + (error "No proof shell buffer to kill!")))) + +(defun proof-shell-bail-out (process event) + "Value for the process sentinel for the proof assistant process. +If the proof assistant dies, run proof-shell-kill-function to +cleanup and remove the associated buffers. The shell buffer is +left around so the user may discover what killed the process." + (message "Process %s %s, shutting down scripting..." process event) + (proof-shell-kill-function) + (message "Process %s %s, shutting down scripting...done." process event)) + +(defun proof-shell-restart () + "Clear script buffers and send `proof-shell-restart-cmd'. +All locked regions are cleared and the active scripting buffer +deactivated. + +If the proof shell is busy, an interrupt is sent with +`proof-interrupt-process' and we wait until the process is ready. + +The restart command should re-synchronize Proof General with the proof +assistant, without actually exiting and restarting the proof assistant +process. + +It is up to the proof assistant how much context is cleared: for +example, theories already loaded may be \"cached\" in some way, +so that loading them the next time round only performs a re-linking +operation, not full re-processing. (One way of caching is via +object files, used by Lego and Coq)." + (interactive) + (if proof-shell-busy + (progn + (proof-interrupt-process) + (proof-shell-wait))) + (if (not (proof-shell-live-buffer)) + ;; If shell not running, start one now. + ;; (Behaviour suggested by Robert Schneck) + (proof-shell-start) + ;; Otherwise, clear all context for running prover + (proof-script-remove-all-spans-and-deactivate) + (proof-shell-clear-state) + (if (and (buffer-live-p proof-shell-buffer) + proof-shell-restart-cmd) + (proof-shell-invisible-command + proof-shell-restart-cmd)))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Response buffer processing +;; + +(defvar proof-shell-no-response-display nil + "A setting to disable displays in the response buffer.") + +(defvar proof-shell-urgent-message-marker nil + "Marker in proof shell buffer pointing to end of last urgent message.") + +(defvar proof-shell-urgent-message-scanner nil + "Marker in proof shell buffer pointing to scan start for urgent messages.") + + +(defun proof-shell-handle-output (start-regexp append-face) + "Displays output from process in `proof-response-buffer'. +The output is taken from `proof-shell-last-output' and begins +the first match for START-REGEXP. +If START-REGEXP is nil, begin from the start of the output for +this command. +This is a subroutine of `proof-shell-handle-error'." + (let (start end string) + (save-excursion + (set-buffer proof-shell-buffer) + (goto-char (point-max)) + (setq end (re-search-backward + ;;end-regexp was always proof-shell-annotated-prompt-regexp + proof-shell-annotated-prompt-regexp)) + (goto-char (marker-position proof-marker)) + (setq start (if start-regexp + (- (re-search-forward start-regexp) + (length (match-string 0))) + (point))) + (setq string (buffer-substring start end)) + ;; FIXME: if the shell buffer is x-symbol minor mode, + ;; this string can contain X-Symbol characters, which + ;; is not suitable for processing with proof-fontify-region. + (unless pg-use-specials-for-fontify + (setq string + (pg-assoc-strip-subterm-markup string))) + ;; Erase if need be, and erase next time round too. + (proof-shell-maybe-erase-response t nil) + (pg-response-display-with-face string append-face)))) + + ;; We used to fetch the output from proof-shell-buffer. I'm not sure what + ;; difference it makes, except that it's difficult to find the actual + ;; output over there and that job has already been done in + ;; proof-shell-filter. -stef + ;; da: Not quite, unfortunately: proof-shell-last-output had + ;; special characters stripped. + ;; This breaks Isabelle, for example, because special + ;; characters have been stripped from proof-shell-last-output, + ;; but start-regexp may contain them. + ;; For now, test _not_ removing specials (see proof-shell-process-output) +; ;; stef's version: +; (let ((string proof-shell-last-output)) +; ;; Strip off start-regexp --- if it matches +; ;; FIXME: if it doesn't we shouldn't be called, but something +; ;; odd happens here now, so add a safety check. +; (if (and start-regexp (string-match start-regexp string)) +; (setq string (substring string (match-beginning 0)))) +; ;; FIXME: if the shell buffer is x-symbol minor mode, +; ;; this string can contain X-Symbol characters, which +; ;; is not suitable for processing with proof-fontify-region. +; (unless pg-use-specials-for-fontify +; (setq string +; (pg-assoc-strip-subterm-markup string))) +; ;; Erase if need be, and erase next time round too. +; (proof-shell-maybe-erase-response t nil) +; (pg-response-display-with-face string append-face))) + + +(defun proof-shell-handle-delayed-output () + "Display delayed output. +This function handles the cases of proof-shell-delayed-output-kind which +are not dealt with eagerly during script processing, namely +'abort, 'response, 'goals outputs." + ;; NB: this function is important even when called with an empty + ;; delayed output, since it serves to clear buffers. + + ;; FIXME: there's a display anomaly here with Isar/shrink mode which + ;; is tricky to find. Error message causes an empty delayed output + ;; for goals buffer to split main window in two rather than + ;; shrinking to fit. Running through the debugger the right + ;; thing happens (display in a correctly sized window). Somewhere + ;; there is a spurious match not protected too: C-c C-n gives + (cond + ;; Response buffer output + ((eq proof-shell-delayed-output-kind 'abort) + ;; "Aborted." why?? + (pg-response-display proof-shell-delayed-output)) + ((eq proof-shell-delayed-output-kind 'response) + (unless proof-shell-no-response-display + (pg-response-display proof-shell-delayed-output))) + ;; Goals buffer output + ((eq proof-shell-delayed-output-kind 'goals) + (pg-goals-display proof-shell-delayed-output)) + ;; Ignore other cases + ) + (run-hooks 'proof-shell-handle-delayed-output-hook)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Processing error output +;; + +(defvar proof-shell-ignore-errors nil + "If non-nil, be quiet about errors from the prover. +An internal setting used in `proof-shell-invisible-cmd-get-result'.") + +;; FIXME: combine next two functions? + +(defun proof-shell-handle-error (cmd) + "React on an error message triggered by the prover. +We first flush unprocessed goals to the goals buffer. +The error message is displayed in the response buffer. +Then we call `proof-shell-error-or-interrupt-action', which see." + ;; [FIXME: Why not flush goals also for interrupts?] + ;; Flush goals or response buffer (from some last successful proof step) + (unless proof-shell-ignore-errors ;; quiet + (save-excursion + (proof-shell-handle-delayed-output)) + (proof-shell-handle-output + (if proof-shell-truncate-before-error proof-shell-error-regexp) + 'proof-error-face) + (proof-display-and-keep-buffer proof-response-buffer)) + (proof-shell-error-or-interrupt-action 'error)) + +(defun proof-shell-handle-interrupt () + "React on an interrupt message from the prover. +Runs `proof-shell-error-or-interrupt-action'." + (unless proof-shell-ignore-errors ;; quiet + (proof-shell-maybe-erase-response t t t) ; force cleaned now & next + (proof-shell-handle-output + (if proof-shell-truncate-before-error proof-shell-interrupt-regexp) + 'proof-error-face) +; (proof-display-and-keep-buffer proof-response-buffer) + (proof-warning + "Interrupt: script management may be in an inconsistent state + (but it's probably okay)")) + (proof-shell-error-or-interrupt-action 'interrupt)) + +(defun proof-shell-error-or-interrupt-action (&optional err-or-int) + "General action when an error or interrupt message appears from prover. +A subroutine for `proof-shell-handle-interrupt' and `proof-shell-handle-error'. + +We sound a beep, clear queue spans and `proof-action-list', and set the flag +`proof-shell-error-or-interrupt-seen' to the ERR-OR-INT argument. +Then we call `proof-shell-handle-error-or-interrupt-hook'." + (save-excursion ;; for safety. + (unless proof-shell-ignore-errors ;; quiet + (beep)) + (proof-script-clear-queue-spans) + (setq proof-action-list nil) + (proof-release-lock err-or-int) + ;; Make sure that prover is outputting data now. + ;; FIXME: put something here! + ;; New: this is called for interrupts too. + (run-hooks 'proof-shell-handle-error-or-interrupt-hook))) + +(defun proof-goals-pos (span maparg) + "Given a span, return the start of it if corresponds to a goal, nil otherwise." + (and (eq 'goal (car (span-property span 'proof-top-element))) + (span-start span))) + +(defun proof-pbp-focus-on-first-goal () + "If the `proof-goals-buffer' contains goals, bring the first one into view. +This is a hook function for proof-shell-handle-delayed-output-hook." + (and proof-running-on-XEmacs ;; FIXME: map-extents exists on Emacs21 + (fboundp 'map-extents) ;; but with different typing + (let + ((pos (map-extents 'proof-goals-pos proof-goals-buffer + nil nil nil nil 'proof-top-element))) + (and pos (set-window-point + (get-buffer-window proof-goals-buffer t) pos))))) + + +(defsubst proof-shell-string-match-safe (regexp string) + "Like string-match except returns nil if REGEXP is nil." + (and regexp (string-match regexp string))) + + +(defun proof-shell-process-output (cmd string) + "Process shell output (resulting from CMD) by matching on STRING. +CMD is the first part of the `proof-action-list' that lead to this +output. The result of this function is a pair (SYMBOL NEWSTRING). + +Here is where we recognizes interrupts, abortions of proofs, errors, +completions of proofs, and proof step hints (proof by pointing results). +They are checked for in this order, using + + `proof-shell-interrupt-regexp' + `proof-shell-error-regexp' + `proof-shell-abort-goal-regexp' + `proof-shell-proof-completed-regexp' + `proof-shell-result-start' + +All other output from the proof engine will be reported to the user in +the response buffer by setting `proof-shell-delayed-output' to a cons +cell of ('insert . TEXT) where TEXT is the text string to be inserted. + +Order of testing is: interrupt, abort, error, completion. + +To extend this function, set `proof-shell-process-output-system-specific'. + +The \"aborted\" case is intended for killing off an open proof during +retraction. Typically it matches the message caused by a +`proof-kill-goal-command'. It simply inserts the word \"Aborted\" into +the response buffer. So it is expected to be the result of a +retraction, rather than the indication that one should be made. + +This function sets `proof-shell-last-output' and `proof-shell-last-output-kind', +which see." + ;; Keep a record of the last message from the prover + (setq proof-shell-last-output string) + (or + ;; First check for error, interrupt, abort, proof completed + (cond + ((proof-shell-string-match-safe proof-shell-interrupt-regexp string) + (setq proof-shell-last-output-kind 'interrupt)) + + ((proof-shell-string-match-safe proof-shell-error-regexp string) + ;; FIXME: is the next setting correct or even needed? + ;; da: removed in pre3.5 test after Stefan's change to + ;; simplify proof-shell-handle-output. + ;;(setq proof-shell-last-output + ;; (pg-assoc-strip-subterm-markup + ;; (substring string (match-beginning 0)))) + (setq proof-shell-last-output-kind 'error)) + + ((proof-shell-string-match-safe proof-shell-abort-goal-regexp string) + (proof-clean-buffer proof-goals-buffer) + (setq proof-shell-last-output-kind 'abort)) + + ((proof-shell-string-match-safe proof-shell-proof-completed-regexp string) + ;; In case no goals display + (proof-clean-buffer proof-goals-buffer) + ;; counter of commands since proof complete. + (setq proof-shell-proof-completed 0) + ;; But! We carry on matching below for goals output, so that + ;; provers may include proof completed message as part of + ;; goals message (Isabelle, HOL) or not (LEGO, Coq). + nil)) + + ;; Check for remaining things + (cond + ((proof-shell-string-match-safe proof-shell-start-goals-regexp string) + (let ((start (match-end 0)) + end) + ;; Find the last goal string in the output + (while (string-match proof-shell-start-goals-regexp string start) + (setq start (match-end 0))) + ;; Convention: provers with special characters appearing in + ;; proof-start-goals-regexp don't include the match in their + ;; goals output. Others do. + ;; (Improvement to examine proof-start-goals-regexp suggested + ;; for Coq by Robert Schneck because Coq has specials but + ;; doesn't markup goals output specially). + (unless (and + pg-subterm-first-special-char + (not (string-equal + proof-shell-start-goals-regexp + (pg-assoc-strip-subterm-markup + proof-shell-start-goals-regexp)))) + (setq start (match-beginning 0))) + (setq end (if proof-shell-end-goals-regexp + (string-match proof-shell-end-goals-regexp string start) + (length string))) + (setq proof-shell-last-output (substring string start end)) + (setq proof-shell-last-output-kind 'goals))) + + ;; Test for a proof by pointing command hint + ((proof-shell-string-match-safe proof-shell-result-start string) + (let (start end) + (setq start (+ 1 (match-end 0))) + (string-match proof-shell-result-end string) + (setq end (- (match-beginning 0) 1)) + ;; Only record the loopback command in the last output message + (setq proof-shell-last-output (substring string start end))) + (setq proof-shell-last-output-kind 'loopback)) + + ;; Hook to tailor proof-shell-process-output to a specific proof + ;; system, in the case that all the above matches fail. + ((and proof-shell-process-output-system-specific + (funcall (car proof-shell-process-output-system-specific) + cmd string)) + (setq proof-shell-last-output-kind 'systemspecific) + (funcall (cdr proof-shell-process-output-system-specific) + cmd string)) + + ;; Finally, any other output will appear as a response. + (t + (setq proof-shell-last-output-kind 'response))))) + + +;; +;; Low-level commands for shell communication +;; + +(defvar proof-shell-insert-space-fudge + (cond + ((string-match "21.*XEmacs" emacs-version) " ") + (proof-running-on-XEmacs "") + (t " ")) + "String to insert after setting proof marker to prevent it moving. +Allows for a difference between different versions of comint across +different Emacs versions.") + +(defun proof-shell-insert (string action) + "Insert STRING at the end of the proof shell, call `comint-send-input'. + +First call `proof-shell-insert-hook'. The argument ACTION may be +examined by the hook to determine how to process the STRING variable. + +Then strip STRING of carriage returns before inserting it and updating +`proof-marker' to point to the end of the newly inserted text. + +Do not use this function directly, or output will be lost. It is only +used in `proof-append-alist' when we start processing a queue, and in +`proof-shell-exec-loop', to process the next item." + (save-excursion + (set-buffer proof-shell-buffer) + (goto-char (point-max)) + + ;; See docstring for this hook: it allows munging of `string' + ;; amongst other hacks. + (run-hooks 'proof-shell-insert-hook) + + ;; Now we replace CRs from string with spaces. This is done + ;; in case CRs in the input strip produce spurious prompts. + + (if proof-shell-strip-crs-from-input + (setq string (subst-char-in-string ?\n ?\ string))) + + (insert string) + + ;; Advance the proof-marker, if synchronization has been gained. + ;; A null marker position indicates that synchronization is not + ;; yet gained. (NB: Any output received before syncrhonization is + ;; gained is ignored!) + (unless (null (marker-position proof-marker)) + (set-marker proof-marker (point))) + + ;; FIXME: consider as possible improvement. + ;; (set-marker proof-shell-urgent-message-marker (point)) + ;; (set-marker proof-shell-urgent-message-scanner (point)) + + ;; FIXME da: this space fudge is actually a visible hack: + ;; the response string begins with a space and a newline. + ;; It was needed to work around differences in Emacs versions. + (insert proof-shell-insert-space-fudge) + (comint-send-input))) + +;; OLD BUGGY CODE here +;; Left in as a warning of a race condition. +;; It seems that comint-send-input can lead to the +;; output filter running before it returns, so that +;; the set-marker call below is executed too late. +;; The result is that the filter deals with +;; the previous portion of output instead of the +;; most recent one! +;; +;; xemacs and FSF emacs have different semantics for what happens when +;; shell input is sent next to a marker +;; the following code accommodates both definitions +; (let ((inserted (point))) +; (comint-send-input) +; (set-marker proof-marker inserted)))) + + +;; ============================================================ +;; +;; Code for manipulating proof queue +;; + + +(defun proof-shell-command-queue-item (cmd callback) + "Return the proof queue entry needed to run CMD with callback CALLBACK." + (list nil cmd callback)) + + +(defun proof-shell-set-silent (span) + "Callback for `proof-shell-start-silent'. +Very simple function but it's important to give it a name to help +track what happens in the proof queue." + (setq proof-shell-silent t)) + +(defun proof-shell-start-silent-item () + "Return proof queue entry for starting silent mode." + (proof-shell-command-queue-item + proof-shell-start-silent-cmd + 'proof-shell-set-silent)) + +(defun proof-shell-clear-silent (span) + "Callback for `proof-shell-stop-silent'. +Very simple function but it's important to give it a name to help +track what happens in the proof queue." + (setq proof-shell-silent nil)) + +(defun proof-shell-stop-silent-item () + "Return proof queue entry for stopping silent mode." + (proof-shell-command-queue-item + proof-shell-stop-silent-cmd + 'proof-shell-clear-silent)) + +;; FIXME: could be macro for efficiency improvement in avoiding calculating num +(defun proof-shell-should-be-silent (num) + "Return non-nil if we must switch to silent mode, adding NUM entries to queue." + (if proof-shell-start-silent-cmd + (or proof-shell-silent ; already + ;; NB: there is some question here over counting the + ;; proof-action-list, since it could itself contain + ;; silent-on/off commands which should be ignored for + ;; counting, really... also makes cutting lists for advanced + ;; queue processing more tricky. + (>= (+ num (length proof-action-list)) + proof-shell-silent-threshold)))) + + +(defun proof-append-alist (alist &optional queuemode) + "Chop off the vacuous prefix of the command queue ALIST and queue it. +For each `proof-no-command' item at the head of the list, invoke its +callback and remove it from the list. + +Append the result onto `proof-action-list', and if the proof +shell isn't already busy, grab the lock with QUEUEMODE and +start processing the queue. + +If the proof shell is busy when this function is called, +then QUEUEMODE must match the mode of the queue currently +being processed." + (let (item) + ;; FIXME: may be wrong time to invoke callbacks for no-op commands, + ;; if the queue is not empty. + (while (and alist (string= + (nth 1 (setq item (car alist))) + proof-no-command)) + (funcall (nth 2 item) (car item)) + (setq alist (cdr alist))) + (if alist + (if proof-action-list + (progn + ;; internal check: correct queuemode in force if busy + ;; (should have proof-action-list<>nil -> busy) + (and proof-shell-busy queuemode + (unless (eq proof-shell-busy queuemode) + (proof-debug "proof-append-alist: wrong queuemode detected for busy shell") + (assert (eq proof-shell-busy queuemode)))) + ;; See if we should make prover quieten down + (if (proof-shell-should-be-silent (length alist)) + ;; Make it ASAP, which is just after the current + ;; command (head of queue). + (setq proof-action-list + (cons (car proof-action-list) + (cons (proof-shell-start-silent-item) + (cdr proof-action-list))))) + ;; append to the current queue + (setq proof-action-list + (nconc proof-action-list alist))) + ;; start processing a new queue + (progn + (proof-grab-lock queuemode) + (setq proof-shell-last-output-kind nil) + (if (proof-shell-should-be-silent (length alist)) + ;; + (progn + (setq proof-action-list + (list (proof-shell-start-silent-item))) + (setq item (car proof-action-list)))) + (setq proof-action-list + (nconc proof-action-list alist)) + ;; Really start things going here + (proof-shell-insert (nth 1 item) (nth 2 item))))))) + +;;;###autoload +(defun proof-start-queue (start end alist) + "Begin processing a queue of commands in ALIST. +If START is non-nil, START and END are buffer positions in the +active scripting buffer for the queue region. + +This function calls `proof-append-alist'." + (if start + (proof-set-queue-endpoints start end)) + (proof-append-alist alist)) + +;;;###autoload +(defun proof-extend-queue (end alist) + "Extend the current queue with commands in ALIST, queue end END. +To make sense, the commands should correspond to processing actions +for processing a region from (buffer-queue-or-locked-end) to END. +The queue mode is set to 'advancing" + (proof-set-queue-endpoints (proof-unprocessed-begin) end) + (proof-append-alist alist 'advancing)) + + + + +(defun proof-shell-exec-loop () + "Process the `proof-action-list'. + +`proof-action-list' contains a list of (SPAN COMMAND ACTION) triples. + +If this function is called with a non-empty proof-action-list, the +head of the list is the previously executed command which succeeded. +We execute (ACTION SPAN) on the first item, then (ACTION SPAN) on any +following items which have `proof-no-command' as their cmd components. +If a there is a next command after that, send it to the process. If +the action list becomes empty, unlock the process and remove the queue +region. + +The return value is non-nil if the action list is now empty." + ;; The loop looks like: Execute the + ;; command, and if it's successful, do action on span. If the + ;; command's not successful, we bounce the rest of the queue and do + ;; some error processing. + + (unless (not proof-action-list) ; exit immediately if finished. + (save-excursion + ;; Switch to active scripting buffer if there is one. + (if proof-script-buffer + (set-buffer proof-script-buffer)) + (let ((item (car proof-action-list))) + ;; Do (action span) on first item in list + (funcall (nth 2 item) (car item)) + (setq proof-action-list (cdr proof-action-list)) + ;; Process following items in list with the form + ;; ("COMMENT" cmd) by calling (cmd "COMMENT") + (while (and proof-action-list + (string= + (nth 1 (setq item (car proof-action-list))) + proof-no-command)) + ;; Do (action span) on comments + (funcall (nth 2 item) (car item)) + (setq proof-action-list (cdr proof-action-list))) + ;; If action list is empty or has a single element, + ;; we want to make sure prover is being noisy. + (if (and proof-shell-silent + (or (null proof-action-list) ; possible? + (null (cdr proof-action-list)))) + (progn + ;; Stick the quieten command onto the queue + (setq proof-action-list + (cons (proof-shell-stop-silent-item) + proof-action-list)) + (setq item (car proof-action-list)))) + ;; If action list is empty now, release the process lock + (if (null proof-action-list) + (progn (proof-release-lock) + (proof-detach-queue) + ;; indicate finished + t) + ;; Otherwise, send the next command to the process. + (proof-shell-insert (nth 1 item) (nth 2 item)) + ;; indicate not finished + nil))))) + +(defun proof-shell-insert-loopback-cmd (cmd) + "Insert command sequence triggered by the proof process +at the end of locked region (after inserting a newline and indenting). +Assume proof-script-buffer is active." + (unless (string-match "^\\s-*$" cmd) ; FIXME: assumes cmd is single line + (save-excursion + (set-buffer proof-script-buffer) + (let (span) + (proof-goto-end-of-locked) + ;; Fix 16.11.99. This attempts to indent current line which can + ;; be read-only. + ;; (newline-and-indent) + (let ((proof-one-command-per-line t)) ; because pbp several commands + (proof-script-new-command-advance)) + (insert cmd) + ;; Fix 16.11.99. Comment in todo suggested old code below + ;; assumed the pbp command would succeed, but it seems fine? + ;; But this action belongs in the proof script code. + ;; NB: difference between ordinary commands and pbp is that + ;; pbp can return *several* commands, that are treated as + ;; a unit, i.e. sent to the proof assistant together. + ;; FIXME da: this seems very similar to proof-insert-pbp-command + ;; in proof-script.el. Should be unified, I suspect. + (setq span (make-span (proof-locked-end) (point))) + (set-span-property span 'type 'pbp) + (set-span-property span 'cmd cmd) + (proof-set-queue-endpoints (proof-locked-end) (point)) + (setq proof-action-list + (cons (car proof-action-list) + (cons (list span cmd 'proof-done-advancing) + (cdr proof-action-list)))))))) + +;; da: first note of this sentence is false! +;; ******** NB ********** +;; While we're using pty communication, this code is OK, since all +;; eager annotations are one line long, and we get input a line at a +;; time. If we go over to piped communication, it will break. + +(defun proof-shell-message (str) + "Output STR in minibuffer." + ;; %s is used below to escape characters special to + ;; 'format' which could appear in STR. + (message "%s" (concat "[" proof-assistant "] " str))) + +(defun proof-shell-process-urgent-message (message) + "Analyse urgent MESSAGE for various cases. +Cases are: included file, retracted file, cleared response buffer, +variable setting or dependency list. +If none of these apply, display MESSAGE. + +MESSAGE should be a string annotated with +`proof-shell-eager-annotation-start', `proof-shell-eager-annotation-end'." + (cond + ;; CASE processing file: the prover is reading a file directly + ;; + ;; FIXME da: this interface is quite restrictive: might be + ;; useful for one message to name several files, or include + ;; an instruction to purge the included files list, rather + ;; than erasing everything and re-adding it. + ;; Contrast retraction interface: there we compute whole + ;; new list. + ;; (Come to think of it, maybe we could unify the two + ;; cases: automatically find removed files and added files + ;; between two versions of proof-included-files-list) + ((and proof-shell-process-file + (string-match (car proof-shell-process-file) message)) + (let + ((file (funcall (cdr proof-shell-process-file) message))) + ;; Special hack: empty string indicates current scripting buffer + ;; (not used anywhere presently?) + ;; (if (and proof-script-buffer (string= file "")) + ;; (setq file (buffer-file-name proof-script-buffer))) + ;; YES! It *was* used by LEGO. + ;; Now we avoid this in favour of altering the processed + ;; files list when the current scripting buffer changes, + ;; inside Proof General. Attempt to harmonize behaviour + ;; with Isabelle. Seems wrong to add "example.l" to + ;; list of processed files if it's only partly processed? + ;; (On the other hand, for lego, it may have declared a + ;; module heading, which is probably Lego's standard + ;; for what a processed file actually is). + (if (and file (not (string= file ""))) + (proof-register-possibly-new-processed-file file)))) + + ;; CASE retract: the prover is retracting across files + ((and proof-shell-retract-files-regexp + (string-match proof-shell-retract-files-regexp message)) + (let ((current-included proof-included-files-list)) + (setq proof-included-files-list + (funcall proof-shell-compute-new-files-list message)) + (let + ;; Previously active scripting buffer + ((scrbuf proof-script-buffer)) + ;; NB: we assume that no new buffers are *added* by + ;; the proof-shell-compute-new-files-list + (proof-restart-buffers + (proof-files-to-buffers + (set-difference current-included + proof-included-files-list))) + (cond + ;; Do nothing if there was no active scripting buffer + ((not scrbuf)) + ;; Do nothing if active scripting buffer hasn't changed + ;; (NB: it might have been nuked) + ((eq scrbuf proof-script-buffer)) + ;; FIXME da: I've forgotten the next condition was needed? + ;; + ;; In fact, it breaks the case that the current scripting + ;; buffer should be deactivated if the prover retracts it. + ;; When scripting begins again in the buffer, other + ;; files may have to be re-read which may not happen unless + ;; scripting is properly de-activated. + ;; + ;; Otherwise, active scripting buffer has been retracted. + ;; Add it back!! Why? Presumably because code likes to + ;; have an active scripting buffer?? + (t + ;; FIXME da: want to test disabling currently active scripting + ;; buffer. Unfortunately this doesn't work with current + ;; use of proof-script-buffer-list: always have to have + ;; *some* scripting buffer active. ARGHH! + ;; FIXME da: test not having this add-back. Then + ;; scripting buffer may change wrongly and randomly + ;; to some other buffer, without running change functions. + ;; + ;; FIXME da: test setting this to nil, scary! + (setq proof-script-buffer nil) + ;;(setq proof-script-buffer-list + ;; (cons scrbuf proof-script-buffer-list)) + ;; (save-excursion + ;; (set-buffer scrbuf) + ;; (proof-init-segmentation))))) + ))) + )) + + ;; CASE clear response: prover asks PG to clear response buffer + ((and proof-shell-clear-response-regexp + (string-match proof-shell-clear-response-regexp message) + proof-response-buffer) + ;; Erase response buffer and possibly its windows. + (proof-shell-maybe-erase-response nil t t)) + + ;; CASE clear goals: prover asks PG to clear goals buffer + ((and proof-shell-clear-goals-regexp + (string-match proof-shell-clear-goals-regexp message) + proof-goals-buffer) + ;; Erase goals buffer but and possibly its windows + (proof-clean-buffer proof-goals-buffer)) + + ;; CASE variable setting: prover asks PG to set some variable + ;; NB: no safety protection whatsoever here, we use blind faith + ;; that the prover will not send malicious elisp!! + ((and proof-shell-set-elisp-variable-regexp + (string-match proof-shell-set-elisp-variable-regexp message)) + (let + ((variable (match-string 1 message)) + (expr (match-string 2 message))) + (condition-case nil + ;; Easiest way to do this seems to be to dump the lisp + ;; string into another buffer -- no direct way to eval + ;; from a string? + (with-temp-buffer + (insert expr) + (set (intern variable) (eval-last-sexp t))) + (t (proof-debug + (concat + "lisp error when obeying proof-shell-set-elisp-variable: \n" + "setting `" variable "'\n to: \n" + expr "\n")))))) + + ;; CASE PGIP message from proof assistant. + ((and proof-shell-match-pgip-cmd + (string-match proof-shell-match-pgip-cmd message)) + (require 'pg-xml) + (require 'pg-pgip) + (unless (string-match (match-string 0) + proof-shell-eager-annotation-start) + ;; Assume that eager annotation regexps are _not_ part of PGIP + ;; message, and strip them. This allows hybrid PGIP/non PGIP + ;; communication, with PGIP embedded in urgent messages. + (setq message + (substring + message + (progn + (string-match proof-shell-eager-annotation-start message) + (match-end 0)) + (string-match proof-shell-eager-annotation-end message)))) + (let + ((parsed-pgip (pg-xml-parse-string message))) + (pg-pgip-process-packet parsed-pgip))) + + ;; CASE theorem dependency: prover lists thms used in last proof + ((and proof-shell-theorem-dependency-list-regexp + (string-match proof-shell-theorem-dependency-list-regexp message)) + (let ((names (match-string 1 message)) + (deps (match-string 2 message))) + (setq proof-last-theorem-dependencies + (cons + (split-string names + proof-shell-theorem-dependency-list-split) + (split-string deps + proof-shell-theorem-dependency-list-split))))) + + ;; CASE tracing output: output in the tracing buffer instead + ;; of the response buffer + ((and proof-shell-trace-output-regexp + (string-match proof-shell-trace-output-regexp message)) + (proof-trace-buffer-display + (if pg-use-specials-for-fontify + message + (pg-assoc-strip-subterm-markup message))) + (proof-display-and-keep-buffer proof-trace-buffer) + ;; Force redisplay in case in a fast loop which keeps Emacs + ;; fully-occupied processing prover output + (and (fboundp 'redisplay-frame) + ;; XEmacs fn + (redisplay-frame)) + ;; If user quits during tracing output, send an interrupt + ;; to the prover. Helps when Emacs is "choking". + (if (and quit-flag proof-action-list) + (proof-interrupt-process))) + + (t + ;; We're about to display a message. Clear the response buffer + ;; if necessary, but don't clear it the next time. + ;; Don't bother remove the window for the response buffer + ;; because we're about to put a message in it. + (proof-shell-maybe-erase-response nil nil) + (let ((stripped (pg-assoc-strip-subterm-markup message))) + ;; Display first chunk of output in minibuffer. + ;; Maybe this should be configurable, it can get noisy. + (proof-shell-message + (substring stripped 0 (or (string-match "\n" stripped) + (min (length stripped) 75)))) + (pg-response-display-with-face + (if pg-use-specials-for-fontify + message + stripped) + 'proof-eager-annotation-face))))) + +(defun proof-shell-process-urgent-messages () + "Scan the shell buffer for urgent messages. +Scanning starts from `proof-shell-urgent-message-scanner' and handles +strings between regexps eager-annotation-start and eager-annotation-end. + +Note that we must search the buffer rather than the chunk of output +being filtered process because we have no guarantees about where +chunks are broken: it may be in the middle of an annotation. + +This is a subroutine of `proof-shell-filter'." + (let ((pt (point)) (end t) lastend start) + (goto-char (marker-position proof-shell-urgent-message-scanner)) + (while (and end + (re-search-forward proof-shell-eager-annotation-start + nil 'end)) + (setq start (match-beginning 0)) + (if (setq end + (re-search-forward proof-shell-eager-annotation-end nil t)) + ;; Process the text including annotations (stripped if specials) + (save-excursion + (setq lastend end) + (proof-shell-process-urgent-message + (buffer-substring start end))))) + ;; Set the marker to the (character after) the end of the last + ;; message found, if any. Must take care to keep the marker + ;; behind the process marker otherwise no output is seen! + ;; (insert-before-markers in comint) + ;; FIXME: maybe we don't need to be as careful as these three checks? + (if lastend + (set-marker + proof-shell-urgent-message-marker + (min lastend + (1- (process-mark (get-buffer-process (current-buffer))))))) + ;; Now an optimization to avoid searching the same bit of text + ;; over and over. But it requires that we know the maximum + ;; possible length of an annotation to avoid missing them. + (if end + ;; If the search for the starting annotation was unsuccessful, + ;; set the scanner marker to the limit of the last search for + ;; the starting annotation, less the maximal length of the + ;; annotation. + (set-marker + proof-shell-urgent-message-scanner + (min + ;; NB: possible fix here not included: a test to be sure we + ;; don't go back before the start of the command! This + ;; fixes a minor problem which is possible duplication + ;; of urgent messages which are less than + ;; proof-shell-eager-annotation-start-length characters. + ;; But if proof-general is configured properly, there + ;; should never be any such messages! + ;; (max + ;; (marker-position proof-marker) + (- (point) proof-shell-eager-annotation-start-length) + (1- (process-mark (get-buffer-process (current-buffer)))))) + ;; Otherwise, the search for the ending annotation was + ;; unsuccessful, so we set the scanner marker to the start of + ;; the annotation found. + (set-marker + proof-shell-urgent-message-scanner + (min + start + (1- (process-mark (get-buffer-process (current-buffer))))))) + (goto-char pt))) + +;; NOTE da: proof-shell-filter does *not* update the proof-marker, +;; that's done in proof-shell-insert. Previous docstring below was +;; wrong. The one case where this function updates proof-marker is +;; the first time through the loop to synchronize. +(defun proof-shell-filter (str) + "Filter for the proof assistant shell-process. +A function for `comint-output-filter-functions'. + +Deal with output and issue new input from the queue. + +Handle urgent messages first. As many as possible are processed, +using the function `proof-shell-process-urgent-messages'. + +Otherwise wait until an annotated prompt appears in the input. +If `proof-shell-wakeup-char' is set, wait until we see that in the +output chunk STR. This optimizes the filter a little bit. + +If a prompt is seen, run `proof-shell-process-output' on the output +between the new prompt and the last input (position of `proof-marker') +or the last urgent message (position of +`proof-shell-urgent-message-marker'), whichever is later. +For example, in this case: + + PROMPT> INPUT + OUTPUT-1 + URGENT-MESSAGE + OUTPUT-2 + PROMPT> + +`proof-marker' is set after INPUT by `proof-shell-insert' and +`proof-shell-urgent-message-marker' is set after URGENT-MESSAGE. +Only OUTPUT-2 will be processed. For this reason, error +messages and interrupt messages should *not* be considered +urgent messages. + +Output is processed using the function +`proof-shell-filter-process-output'. + +The first time that a prompt is seen, `proof-marker' is +initialised to the end of the prompt. This should +correspond with initializing the process. The +ordinary output before the first prompt is ignored (urgent messages, +however, are always processed; hence their name)." + (save-excursion + ;; Strip CRs. + (if proof-shell-strip-crs-from-output + (progn + (setq str (replace-regexp-in-string "\r+$" "" str)) + ;; Do the same thing in the buffer via comint's function + ;; (sometimes put on comint-output-filter-functions too). + (comint-strip-ctrl-m))) + + ;; Process urgent messages. + (and proof-shell-eager-annotation-start + (proof-shell-process-urgent-messages)) + + ;; FIXME da: some optimization possible here by customizing filter + ;; according to whether proof-shell-wakeup-char, etc, are non-nil. + ;; Could make proof-shell-filter into a macro to do this. + ;; On the other hand: it's not clear that wakeup-char is really + ;; needed, as matching the prompt may be efficient enough anyway. + + (if ;; Some proof systems can be hacked to have annotated prompts; + ;; for these we set proof-shell-wakeup-char to the annotation + ;; special, and look for it in the output before doing anything. + (if proof-shell-wakeup-char + ;; FIXME: this match doesn't work in emacs-mule, darn. + ;; (string-match (char-to-string proof-shell-wakeup-char) str)) + ;; FIXME: this match doesn't work in FSF emacs 20.5, darn. + ;; (find proof-shell-wakeup-char str) + ;; FIXME: [3.1] temporarily, use both tests! + (or + (string-match (char-to-string proof-shell-wakeup-char) str) + (find proof-shell-wakeup-char str)) + ;; Others systems rely on a standard top-level (e.g. SML) whose + ;; prompts may be difficult or impossible to hack. + ;; For those we must search in the buffer for the prompt. + t) + (if (null (marker-position proof-marker)) + ;; Initialisation of proof-marker: + ;; Set marker to after the first prompt in the + ;; output buffer if one can be found now. + ;; FIXME da: we'd rather do this initialization outside + ;; of the filter function for better efficiency! + (progn + (goto-char (point-min)) + (if (re-search-forward proof-shell-annotated-prompt-regexp nil t) + (progn + (set-marker proof-marker (point)) + ;; The first time a prompt is seen we ignore any + ;; output that occured before it, assuming that + ;; corresponds to uninteresting startup messages. + ;; We process the + ;; action list to remove the first item if need + ;; be (proof-shell-init-cmd sent if + ;; proof-shell-config-done). + (if proof-action-list + (proof-shell-filter-process-output ""))))) + ;; Now we're looking for the end of the piece of output + ;; which will be processed. + + ;; The blasphemous situation that the proof-action-list + ;; is empty is now quietly ignored so that users can + ;; type in the shell buffer without being screamed at. + ;; Also allows the process to output something for + ;; some other reason (perhaps it's just being chatty), + ;; although that could break the synchronization. + ;; Note that any "unexpected" output like this gets + ;; ignored. + (if proof-action-list + (let ((urgnt (marker-position + proof-shell-urgent-message-marker)) + string startpos) + ;; Ignore any urgent messages that have already been + ;; dealt with. This loses in the case mentioned above. + ;; A more general way of doing this would be + ;; to filter out or delete the urgent messages which + ;; have been processed already. + (setq startpos (goto-char (marker-position proof-marker))) + (if (and urgnt + (< startpos urgnt)) + (setq startpos (goto-char urgnt)) + ;; Otherwise, skip possibly a (fudge) space and new line + (if (eq (char-after startpos) ?\ ) + (setq startpos (goto-char (+ 2 startpos))) + (setq startpos (goto-char (1+ startpos))))) + ;; Find next prompt. + ;; The process might have sent us several things with + ;; prompts in-between, so we have to loop. -stef + (while (re-search-forward + proof-shell-annotated-prompt-regexp nil t) + (progn + (setq proof-shell-last-prompt + (buffer-substring (match-beginning 0) (match-end 0))) + ;; NB: decoding x-symbols here is perhaps a bit + ;; expensive; moreover it leads to problems + ;; processing special characters as annotations + ;; later on. So no fontify or decode. + ;; (proof-fontify-region startpos (point)) + (setq string (buffer-substring startpos (match-beginning 0))) + ;; We are positioned right after a prompt output by the + ;; process. If there's anything ahead, it's also output + ;; from the process. Insert a newline to be sure that + ;; it won't look like input text sent to the process + ;; and so that "^" anchoring works right when matching + ;; process' output. -stef + (unless (eolp) (newline)) + ;; Process output string. + (if (and (not proof-shell-strip-crs-from-input) + (equal string "") (not (eobp))) + ;; If there was no actual content apart from the + ;; prompt and if there's more output ahead to + ;; process, let's assume that this prompt was just + ;; a spurious result of having sent newlines in + ;; the input. + ;; This is fundamentally ambiguous because we can't + ;; tell the difference between such spurious prompts + ;; and actual empty output: if a multiline command + ;; returns no output, a human would have to type a + ;; silly command and wait for an answer to tell if + ;; the process was done or was still busy (short of + ;; counting prompts, of course). + ;; But we will call proof-shell-filter-process-output + ;; at least once, which is as good as the old code. + ;; We may call it too many times (with an empty + ;; string) because of those spurious prompts but + ;; it hopefully shouldn't lead to any disastrous + ;; effect other than displaying an empty response + ;; and discarding the actual non-empty one. + nil + (proof-shell-filter-process-output string)) + (setq startpos (set-marker proof-marker (point)))))) + ;; If proof-action-list is empty, make sure the process lock + ;; is not held! This should solve continual "proof shell busy" + ;; error messages which sometimes occur during development, + ;; at least. + (if proof-shell-busy + (progn + (proof-debug + "proof-shell-filter found empty action list yet proof shell busy.") + (proof-release-lock)))))))) + + + +(defun proof-shell-filter-process-output (string) + "Subroutine of `proof-shell-filter' to process output STRING. + +Appropriate action is taken depending on what +`proof-shell-process-output' returns: maybe handle an interrupt, an +error, or deal with ordinary output which is a candidate for the goal +or response buffer. Ordinary output is only displayed when the proof +action list becomes empty, to avoid a confusing rapidly changing +output. + +After processing the current output, the last step undertaken +by the filter is to send the next command from the queue." + ;; If we don't strip \n from input, we may get spurious prompts. + ;; Ignore the corresponding empty-string. + (let + ;; Some functions may care which command invoked them + ((cmd (nth 1 (car proof-action-list)))) + (save-excursion + ;; + (proof-shell-process-output cmd string) + ;; da: Added this next line to redisplay, for proof-toolbar + ;; FIXME: should do this for all frames displaying the script + ;; buffer! + ;; ODDITY: has strange effect on highlighting, leave it. + ;; (redisplay-frame (window-buffer t) + (cond + ((eq proof-shell-last-output-kind 'error) + (proof-shell-handle-error cmd)) + ((eq proof-shell-last-output-kind 'interrupt) + (proof-shell-handle-interrupt)) + ((eq proof-shell-last-output-kind 'loopback) + (proof-shell-insert-loopback-cmd proof-shell-last-output) + (proof-shell-exec-loop)) + ;; Otherwise, it's something that we should delay + ;; handling: we don't act on it unless all the commands + ;; in the queue region have been processed. + ;; (e.g. goals/response message) + (t + (setq proof-shell-delayed-output-kind proof-shell-last-output-kind) + (setq proof-shell-delayed-output proof-shell-last-output) + (if (proof-shell-exec-loop) + (proof-shell-handle-delayed-output))))))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Utility functions +;; +(defun proof-shell-dont-show-annotations (&optional buffer) + "Set display values of annotations in BUFFER to be invisible. + +Annotations are characters 128-255." + (interactive) + (with-current-buffer (or buffer (current-buffer)) + (let ((disp (make-display-table)) + (i 128)) + (while (< i 256) + (aset disp i []) + (incf i)) + (cond ((fboundp 'add-spec-to-specifier) + (add-spec-to-specifier current-display-table disp (current-buffer))) + ((boundp 'buffer-display-table) + (setq buffer-display-table disp)))))) + +(defun proof-shell-show-annotations () + "Remove display table specifier from current buffer. +This function is for testing purposes only, to reveal 8-bit characters +in the shell buffer. Use proof-shell-dont-show-annotations to turn +them off again. +XEmacs only." + (interactive) + (remove-specifier current-display-table (current-buffer))) + + + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; proof-shell-invisible-command: for user-level commands. +;; + +;;;###autoload +(defun proof-shell-wait (&optional timeout) + "Busy wait for `proof-shell-busy' to become nil, or for TIMEOUT seconds. +Needed between sequences of commands to maintain synchronization, +because Proof General does not allow for the action list to be extended +in some cases. May be called by `proof-shell-invisible-command'." + (while proof-shell-busy + (accept-process-output nil timeout) + (sit-for 0))) + + +(defun proof-done-invisible (span) + "Callback for proof-shell-invisible-command. +Calls proof-state-change-hook." + (run-hooks 'proof-state-change-hook)) + +; new code to experiment with after 3.2 +;(defun proof-done-invisible (&optional span) +; "Callback for proof-shell-invisible-command. +;Calls proof-state-change-hook." +; (run-hooks 'proof-state-change-hook) +; (remove-hook 'proof-shell-handle-error-or-interrupt-hook +; 'proof-shell-invisible-hook-fn)) +;; Seems to be hard to write this stuff without a temporary variable +;; (or higher-order functions, sob). +;(defun proof-shell-invisible-hook-fn () +; "Temporary function holding hook for proof-shell-invisible-command.") + +;(defmacro proof-shell-invisible-failure-msg (errormsg) +; "Construct a value for `proof-shell-handle-error-or-interrupt-hook'. +;Give error message ERRORMSG, then remove self from queue." +; `(lambda () +; (proof-done-invisible) +; (error ,(eval errormsg)))) + +;(defmacro proof-shell-invisible-failure-fn (fn) +; "Construct a value for `proof-shell-handle-error-or-interrupt-hook'. +;Call function fn, then remove self from queue." +; `(lambda () +; (proof-done-invisible) +; (,(eval fn)))) +; +; extra arg ERRORMSGFN to proof-shell-invisible-command: +; +;If ERRORMSGFN is non-nil, if the command leads to an error or interrupt +;in the proof assistant, we will give an error. If ERRORMSGFN +;is a string, (error ERRORMSGFN) is called; if ERRORMSGFN is a function, +;it is called directly. If ERRORMSGFN is not a string or function, +;we will give standard error messages for interrupts and errors." +; +; Other (sensible) possibility is to call +; proof-shell-handle-error-or-interrupt-hook with span as argument. + +;;;###autoload +(defun proof-shell-invisible-command (cmd &optional wait) + "Send CMD to the proof process. +CMD may be a string or a string-yielding function. +Automatically add proof-terminal-char if necessary, examining +proof-shell-no-auto-terminate-commands. +By default, let the command be processed asynchronously. +But if optional WAIT command is non-nil, wait for processing to finish +before and after sending the command. +If WAIT is an integer, wait for that many seconds afterwards." + (unless (stringp cmd) + (setq cmd (eval cmd))) + (unless (or (null proof-terminal-char) + (not proof-shell-auto-terminate-commands) + (string-match (concat + (regexp-quote + (char-to-string proof-terminal-char)) + "[ \t]*$") cmd)) + (setq cmd (concat cmd (char-to-string proof-terminal-char)))) + (if wait (proof-shell-wait)) + (proof-shell-ready-prover) ; start proof assistant; set vars. + (proof-start-queue nil nil + (list (proof-shell-command-queue-item + cmd 'proof-done-invisible))) + (if wait (proof-shell-wait (if (numberp wait) wait)))) + +(defun proof-shell-invisible-cmd-get-result (cmd &optional noerror) + "Execute CMD and return result as a string. +This expects CMD to print something to the response buffer. +The output in the response buffer is disabled, and the result +\(contents of `proof-shell-last-output') is returned as a +string instead. + +Errors are not supressed and will result in a display as +usual, unless NOERROR is non-nil." + (setq proof-shell-no-response-display t) + (setq proof-shell-ignore-errors noerror) + (unwind-protect + (proof-shell-invisible-command cmd 'waitforit) + (setq proof-shell-no-response-display nil) + (setq proof-shell-ignore-errors nil)) + proof-shell-last-output) + + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Proof General shell mode definition +;; + +(eval-and-compile ; to define vars +;;; NB: autoload tag below doesn't work for d-d-m, autoload is in proof.el +;;;###autoload +(define-derived-mode proof-shell-mode comint-mode + "proof-shell" "Proof General shell mode class for proof assistant processes" + + (setq proof-buffer-type 'shell) + + ;; Clear state + (proof-shell-clear-state) + + (make-local-variable 'proof-shell-insert-hook) + + ;; Efficiency: don't keep undo history + (buffer-disable-undo) + + ;; comint customisation. comint-prompt-regexp is used by + ;; comint-get-old-input, comint-skip-prompt, comint-bol, backward + ;; matching input, etc. + (if proof-shell-prompt-pattern + (setq comint-prompt-regexp proof-shell-prompt-pattern)) + + ;; An article by Helen Lowe in UITP'96 suggests that the user should + ;; not see all output produced by the proof process. + (remove-hook 'comint-output-filter-functions + 'comint-postoutput-scroll-to-bottom 'local) + + (add-hook 'comint-output-filter-functions 'proof-shell-filter nil 'local) + (setq comint-get-old-input (function (lambda () ""))) + + ;; FIXME: this is a work-around for a nasty GNU Emacs 21.2 + ;; bug which HANGS Emacs sometimes if special characters + ;; are hidden. (e.g. try M-x column-number-mode) + (unless proof-running-on-Emacs21 + (proof-shell-dont-show-annotations)) + + ;; Proof marker is initialised in filter to first prompt found + (setq proof-marker (make-marker)) + ;; Urgent message marker records end position of last urgent + ;; message seen. + (setq proof-shell-urgent-message-marker (make-marker)) + ;; Urgent message scan marker records starting position to + ;; scan for urgent messages from + (setq proof-shell-urgent-message-scanner (make-marker)) + (set-marker proof-shell-urgent-message-scanner (point-min)) + + ;; easy-menu-add must be in the mode function for XEmacs. + (easy-menu-add proof-shell-mode-menu proof-shell-mode-map) + + ;; [ Should already be in proof-goals-buffer, really.] + + ;; FIXME da: before entering proof assistant specific code, + ;; we'd do well to check that process is actually up and + ;; running now. If not, call the process sentinel function + ;; to display the buffer, and give an error. + ;; (Problem to fix is that process can die before sentinel is set: + ;; it ought to be set just here, perhaps: but setting hook here + ;; had no effect for some odd reason). + ;; What actually happens: an obscure infinite loop somewhere + ;; that can lead to "lisp nesting exceeded" somewhere, when + ;; shell startup fails. Ugly, but low priority to fix. + )) + +(easy-menu-define proof-shell-mode-menu + proof-shell-mode-map + "Menu used in Proof General shell mode." + proof-aux-menu) + + +;; +;; Sanity checks on important settings +;; + +(defconst proof-shell-important-settings + '(proof-shell-annotated-prompt-regexp ; crucial + )) + + +(defun proof-shell-config-done () + "Initialise the specific prover after the child has been configured. +Every derived shell mode should call this function at the end of +processing." + (save-excursion + (set-buffer proof-shell-buffer) + + ;; Give warnings if some crucial settings haven't been made + (dolist (sym proof-shell-important-settings) + (proof-warn-if-unset "proof-shell-config-done" sym)) + + ;; We do not use font-lock here, it's a waste of cycles. + ;; (proof-font-lock-configure-defaults nil) + + (let ((proc (get-buffer-process proof-shell-buffer))) + ;; Add the kill buffer function and process sentinel + (make-local-hook 'kill-buffer-hook) + (add-hook 'kill-buffer-hook 'proof-shell-kill-function t t) + (set-process-sentinel proc 'proof-shell-bail-out) + + ;; Pre-sync initialization command. This is necessary + ;; for proof assistants which change their output modes + ;; only after some initializations. + (if proof-shell-pre-sync-init-cmd + (proof-shell-insert proof-shell-pre-sync-init-cmd 'init-cmd)) + + ;; Flush pending output from startup (it gets hidden from the user) + ;; while waiting for the prompt to appear + (while (and (process-live-p proc) + (null (marker-position proof-marker))) + (accept-process-output proc 1)) + + (if (process-live-p proc) + (progn + ;; Send main intitialization command and wait for it to be + ;; processed. Also ensure that proof-action-list is initialised. + (setq proof-action-list nil) + (if proof-shell-init-cmd + (proof-shell-invisible-command proof-shell-init-cmd t)) + + ;; Configure for x-symbol + (proof-x-symbol-shell-config)))))) + + +(provide 'proof-shell) +;; proof-shell.el ends here. diff --git a/generic/proof-site.el b/generic/proof-site.el new file mode 100644 index 00000000..9f60cdb5 --- /dev/null +++ b/generic/proof-site.el @@ -0,0 +1,397 @@ +;; proof-site.el -- Loading stubs for Proof General. +;; Configuration for site and choice of provers. +;; +;; Copyright (C) 1998-2002 LFCS Edinburgh. +;; Author: David Aspinall <da@dcs.ed.ac.uk> +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; NB: Normally you will not need to edit this file. +;; + +(if (featurep 'proof-site) + nil ; don't load twice + +(if (or (not (boundp 'emacs-major-version)) + (< emacs-major-version 20)) + (error "Proof General is not compatible with Emacs %s" emacs-version)) + +(defgroup proof-general nil + "Customization of Proof General." + :group 'external + :group 'processes + :prefix "proof-") + + +;; This customization group gathers together +;; the internals of Proof General which control +;; configuration to different proof assistants. +;; This is for development purposes rather than +;; user-level customization, so this group does +;; not belong to 'proof-general (or any other group). +(defgroup proof-general-internals nil + "Customization of Proof General internals." + :prefix "proof-") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Directories +;; +(defun proof-home-directory-fn () + "Used to set proof-home-directory" + (let ((s (getenv "PROOFGENERAL_HOME"))) + (if s + (if (string-match "/$" s) s (concat s "/")) + (let ((curdir + (or + (and load-in-progress (file-name-directory load-file-name)) + (file-name-directory (buffer-file-name))))) + (file-name-directory (substring curdir 0 -1)))))) + +(defcustom proof-home-directory + (proof-home-directory-fn) + "Directory where Proof General is installed. Ends with slash. +Default value taken from environment variable `PROOFGENERAL_HOME' if set, +otherwise based on where the file `proof-site.el' was loaded from. +You can use customize to set this variable." + :type 'directory + :group 'proof-general-internals) + +(defcustom proof-images-directory + (concat proof-home-directory "images/") + "Where Proof General image files are installed. Ends with slash." + :type 'directory + :group 'proof-general-internals) + +(defcustom proof-info-directory + (concat proof-home-directory "doc/") + "Where Proof General Info files are installed. Ends with slash." + :type 'directory + :group 'proof-general-internals) + +;; Add the info directory to the end of Emacs Info path if need be. +(if ;; NB: proof-info-directory is bogus in RPM distrib. + (file-exists-p proof-info-directory) + (if (and (boundp 'Info-directory-list) (consp Info-directory-list)) + ;; Info is already initialized. Update its variables. + ;; This probably never happens. -stef + (if (not (member proof-info-directory Info-directory-list)) + (progn + (setq Info-directory-list + (cons proof-info-directory Info-directory-list)) + (setq Info-dir-contents nil))) + ;; Info is not yet initialized. Change its default. + (if (not (member proof-info-directory Info-default-directory-list)) + (setq Info-default-directory-list + (cons proof-info-directory Info-default-directory-list))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Master table of supported proof assistants. +;; +(defcustom proof-assistant-table + (apply + 'append + (mapcar + ;; Discard entries whose directories have been removed. + (lambda (dne) + (let ((atts (file-attributes (concat proof-home-directory + (symbol-name (car dne)))))) + (if (and atts (eq 't (car atts))) + (list dne) + nil))) + '(;; For demonstration instance of Proof General, + ;; export PROOFGENERAL_ASSISTANTS=demoisa. + ;; + ;; To use Isabelle/Isar instead of classic Isabelle, + ;; export PROOFGENERAL_ASSISTANTS=isar + ;; + (demoisa "Isabelle Demo" "\\.ML$") + (isa "Isabelle" "\\.ML$\\|\\.thy$") + (isar "Isabelle/Isar" "\\.thy$") + (lego "LEGO" "\\.l$") + (coq "Coq" "\\.v$") + (phox "PhoX" "\\.phx$") + ;; The following provers are not fully supported, and have only + ;; preliminary support written (please volunteer to improve them!) + (hol98 "HOL" "\\.sml$") + (acl2 "ACL2" "\\.acl2$") + (twelf "Twelf" "\\.elf$") + ;; The following provers have experimental support, WIP + (plastic "Plastic" "\\.lf$") + (lclam "Lambda-CLAM" "\\.lcm$") + ;; Next line for testing only + ;; (pgip "PGIP/Isa" "\\.ML$\\|\\.thy$") + ))) + "*Proof General's table of supported proof assistants. +Extend this table to add a new proof assistant. +Each entry is a list of the form + + (SYMBOL NAME AUTOMODE-REGEXP) + +The NAME is a string, naming the proof assistant. +The SYMBOL is used to form the name of the mode for the +assistant, `SYMBOL-mode', run when files with AUTOMODE-REGEXP +are visited. SYMBOL is also used to form the name of the +directory and elisp file for the mode, which will be + + PROOF-HOME-DIRECTORY/SYMBOL/SYMBOL.el + +where `PROOF-HOME-DIRECTORY' is the value of the +variable proof-home-directory." + :type '(repeat (list symbol string string)) + :group 'proof-general-internals) + + + + + +;; A utility function. Is there an alternative? +(defun proof-string-to-list (s separator) + "Return the list of words in S separated by SEPARATOR. +If S is nil, return empty list." + (if s + (let ((end-of-word-occurence (string-match (concat separator "+") s))) + (if (not end-of-word-occurence) + (if (string= s "") + nil + (list s)) + (cons (substring s 0 end-of-word-occurence) + (proof-string-to-list + (substring s + (string-match (concat "[^" separator "]") + s end-of-word-occurence)) + separator)))))) + +(defcustom proof-assistants nil + (concat + "*Choice of proof assistants to use with Proof General. +A list of symbols chosen from:" + (apply 'concat (mapcar (lambda (astnt) + (concat " '" (symbol-name (car astnt)))) + proof-assistant-table)) +".\nIf nil, the default will be ALL proof assistants. + +Each proof assistant defines its own instance of Proof General, +providing session control, script management, etc. Proof General +will be started automatically for the assistants chosen here. +To avoid accidently invoking a proof assistant you don't have, +only select the proof assistants you (or your site) may need. + +You can select which proof assistants you want by setting this +variable before `proof-site.el' is loaded, or by setting +the environment variable `PROOFGENERAL_ASSISTANTS' to the +symbols you want, for example \"lego isa\". Or you can +edit the file `proof-site.el' itself. + +Note: to change proof assistant, you must start a new Emacs session.") + :type (cons 'set + (mapcar (lambda (astnt) + (list 'const ':tag (car (cdr astnt)) (car astnt))) + proof-assistant-table)) + :group 'proof-general) + + +;; Extend load path for the generic files. +(let ((proof-lisp-path + (concat proof-home-directory "generic/"))) + (or (member proof-lisp-path load-path) + (setq load-path + (cons proof-lisp-path load-path)))) + +;; During compilation from the Makefile, generic is on the load path. +;; Add all of the prover directories. +;; FIXME: this doesn't work quite right. We want to test +;; whether we are running during a compilation. How? +; (eval-when-compile +; (dolist (assistant proof-assistant-table) +; (let ((path (concat proof-home-directory +; (concat (symbol-name (car assistant)) "/")))) +; (or (member path load-path) +; (setq load-path +; (cons path load-path)))))) + +(defun proof-ready-for-assistant (assistant-name assistantsym) + "Configure PG for ASSISTANT-NAME, symbol ASSISTANTSYM." + (let* + ((sname (symbol-name assistantsym)) + (cusgrp-rt + ;; Normalized a bit to remove spaces and funny characters + ;; FIXME UGLY compatibility hack + ;; (can use cl macro `substitute' but want to avoid cl here) + (if (fboundp 'replace-in-string) + ;; XEmacs + (replace-in-string (downcase assistant-name) "/\\|[ \t]+" "-") + ;; FSF + (subst-char-in-string + ?/ ?\- + (subst-char-in-string ?\ ?\- (downcase assistant-name))))) + ;; END compatibility hack + (cusgrp (intern cusgrp-rt)) + (cus-internals (intern (concat cusgrp-rt "-config"))) + ;; NB: Dir name for each prover is the same as its symbol name! + (elisp-dir sname) + (loadpath-elt (concat proof-home-directory elisp-dir "/"))) + (eval `(progn + ;; Make a customization group for this assistant + (defgroup ,cusgrp nil + ,(concat "Customization of user options for " assistant-name + " Proof General.") + :group 'proof-general) + ;; And another one for internals + (defgroup ,cus-internals nil + ,(concat "Customization of internal settings for " + assistant-name " configuration.") + :group 'proof-general-internals + :prefix ,(concat sname "-")) + + ;; Set the proof-assistant configuration variables + ;; NB: tempting to use customize-set-variable: wrong! + ;; Here we treat customize as extended docs for these + ;; variables. + (setq proof-assistant-cusgrp (quote ,cusgrp)) + (setq proof-assistant-internals-cusgrp (quote ,cus-internals)) + (setq proof-assistant ,assistant-name) + (setq proof-assistant-symbol (quote ,assistantsym)) + ;; Extend the load path if necessary + (if (not (member ,loadpath-elt load-path)) + (setq load-path (cons ,loadpath-elt load-path))))))) + +;; Now add auto-loads and load-path elements to support the +;; proof assistants selected, and define a stub +(let ((assistants + (or (mapcar 'intern + (proof-string-to-list + (getenv "PROOFGENERAL_ASSISTANTS") " ")) + proof-assistants + (mapcar (lambda (astnt) (car astnt)) proof-assistant-table)))) + (while assistants + (let* + ((assistant (car assistants)) ; compiler bogus warning here + (nameregexp + (or + (cdr-safe + (assoc assistant + proof-assistant-table)) + (error "proof-site: symbol " (symbol-name assistant) + "is not in proof-assistant-table"))) + (assistant-name (car nameregexp)) + (regexp (car (cdr nameregexp))) + (sname (symbol-name assistant)) + ;; NB: File name for each prover is the same as its symbol name! + (elisp-file sname) + ;; NB: Mode name for each prover is <symbol name>-mode! + (proofgen-mode (intern (concat sname "-mode"))) + ;; NB: Customization group for each prover is its l.c.'d name! + + ;; Stub to do some automatic initialization and load + ;; the specific code. + (mode-stub + `(lambda () + ,(concat + "Major mode for editing scripts for proof assistant " + assistant-name + ".\nThis is a stub which loads the real function.") + (interactive) + ;; Give a message and stop loading if proof-assistant is + ;; already set: things go wrong if proof general is + ;; loaded for more than one prover. + (cond + ((and (boundp 'proof-assistant) + (not (string-equal proof-assistant ""))) + (or (string-equal proof-assistant ,assistant-name) + ;; If Proof General was partially loaded last time + ;; and mode function wasn't redefined, be silent. + (message + (concat + ,assistant-name + " Proof General error: Proof General already in use for " + proof-assistant)))) + (t + ;; prepare variables and load path + (proof-ready-for-assistant ,assistant-name + (quote ,assistant)) + ;; load the real mode and invoke it. + (load-library ,elisp-file) + (,proofgen-mode)))))) + + (setq auto-mode-alist + (cons (cons regexp proofgen-mode) auto-mode-alist)) + + (fset proofgen-mode mode-stub) + + (setq assistants (cdr assistants)) + ))) + +;; WARNING: do not edit below here +;; (the next constant is set automatically, also its form is +;; relied upon in proof-config.el, for proof-splash-contents) +(defconst proof-general-version "Proof General Version 3.5pre021111. Released by da." + "Version string identifying Proof General release.") + +;; Now define a few autoloads and basic variables. + +;; 1.8.01: add a dummy package-provide command so proof-autoloads +;; is compatible with FSF Emacs. Needed for next provide +;; (otherwise would be in proof-compat.el). +(or (fboundp 'package-provide) + (defun package-provide (name &rest attributes) + "Dummy version of XEmacs function for FSF compatibility.")) + + +(require 'proof-autoloads) ; autoloaded functions + +(defcustom proof-assistant-cusgrp nil + "Symbol for the customization group of the user options for the proof assistant. +Do not change this variable! It is set automatically by the mode +stub defined in proof-site, from the name given in +proof-assistant-table." + :type 'sexp + :group 'prover-config) + +(defcustom proof-assistant-internals-cusgrp nil + "Symbol for the customization group of the PG internal settings proof assistant. +Do not change this variable! It is set automatically by the mode +stub defined in proof-site, from the name given in +proof-assistant-table." + :type 'sexp + :group 'prover-config) + +(defcustom proof-assistant "" + "Name of the proof assistant Proof General is using. +Do not change this variable! It is set automatically by the mode +stub defined in proof-site, from the name given in +proof-assistant-table." + :type 'string + :group 'prover-config) + +(defcustom proof-assistant-symbol nil + "Symbol for the proof assistant Proof General is using. +Used for automatic configuration based on standard variable names. +Settings will be found by looking for names beginning with this +symbol as a prefix. +Do not change this variable! It is set automatically by the mode +stub defined in proof-site, from the symbols given in +proof-assistant-table." + :type 'sexp + :group 'prover-config) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Architecture flags +;;; + +(eval-and-compile +(defvar proof-running-on-XEmacs (string-match "XEmacs" emacs-version) + "Non-nil if Proof General is running on XEmacs.") +(defvar proof-running-on-Emacs21 (and (not proof-running-on-XEmacs) + (>= emacs-major-version 21)) + "Non-nil if Proof General is running on GNU Emacs 21 or later.") +;; rough test for XEmacs on win32, anyone know about GNU Emacs on win32? +(defvar proof-running-on-win32 (fboundp 'win32-long-file-name) + "Non-nil if Proof General is running on a win32 system.")) + +(provide 'proof-site)) +;; proof-site.el ends here diff --git a/generic/proof-splash.el b/generic/proof-splash.el new file mode 100644 index 00000000..4532f57a --- /dev/null +++ b/generic/proof-splash.el @@ -0,0 +1,286 @@ +;; proof-splash.el -- Splash welcome screen for Proof General +;; +;; Copyright (C) 1998-2001 LFCS Edinburgh. +;; Author: David Aspinall +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Customization of splash screen (was in proof-config) + +(defcustom proof-splash-enable t + "*If non-nil, display a splash screen when Proof General is loaded." + :type 'boolean + :group 'proof-user-options) + +(defcustom proof-splash-time 2 + "Minimum number of seconds to display splash screen for. +The splash screen may be displayed for a couple of seconds longer than +this, depending on how long it takes the machine to initialise +Proof General." + :type 'number + :group 'proof-general-internals) + +(defcustom proof-splash-contents + '(list + nil +;;; Remove the text for now: XEmacs makes a mess of displaying the +;;; transparent parts of the gif (at least, on all machines I have seen) +;;; (proof-get-image "pg-text" t) + nil + (proof-get-image "ProofGeneral") + nil + "Welcome to" + (concat proof-assistant " Proof General!") + nil + (substring proof-general-version + (string-match "Version [^ ]+ " + proof-general-version) + (match-end 0)) + nil + "(C) LFCS, University of Edinburgh, 2002." + nil + nil +" Please send problems and suggestions to support@proofgeneral.org, + or use the menu command Proof-General -> Submit bug report." + nil + (unless (or proof-running-on-XEmacs proof-running-on-Emacs21) + "For a better Proof General experience, please use XEmacs or Emacs 21.X")) + "Evaluated to configure splash screen displayed when entering Proof General. +A list of the screen contents. If an element is a string or an image +specifier, it is displayed centred on the window on its own line. +If it is nil, a new line is inserted." + :type 'sexp + :group 'proof-general-internals) + +(defconst proof-splash-startup-msg + '(if (featurep 'proof-config) nil + ;; Display additional hint if we guess we're being loaded + ;; by shell script rather than find-file. + '(list + "To start using Proof General, visit a proof script file" + "for your prover, using C-x C-f or the \"File\" menu.")) + "Additional form evaluated and put onto splash screen.") + +(defconst proof-splash-welcome "*Proof General Welcome*" + "Name of the Proof General splash buffer.") + +;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;; Compatibility between Emacs/XEmacs. +(if (string-match "XEmacs" emacs-version) + ;; Constant nil function + (defun proof-emacs-imagep (img) + "See if IMG is an Emacs 21 image descriptor (returns nil since not E21)." + nil) + (defun proof-emacs-imagep (img) + "See if IMG is an Emacs 21 image descriptor." + (and (listp img) (eq (car img) 'image)))) + + +;; could be in proof-utils +(defun proof-get-image (name &optional nojpeg default) + "Construct an image instantiator for an image, or string failing that. +Different formats are chosen from according to what can be displayed. +Unless NOJPEG is set, try jpeg first. Then try gif, then xpm. +Gif filename depends on colour depth of display. +DEFAULT gives return value in case image not valid." + (let ((jpg (vector 'jpeg :file + (concat proof-images-directory name ".jpg"))) + (gif (vector 'gif :file + (concat proof-images-directory + name + (or (and + (fboundp 'device-pixel-depth) + (> (device-pixel-depth) 8) + ".gif") + ;; Low colour gif for poor displays + ".8bit.gif")))) + (xpm (vector 'xpm :file + (concat proof-images-directory name ".xpm"))) + (validfn (lambda (inst) + (and (valid-instantiator-p inst 'image) + (file-readable-p (aref inst 2))))) + img) + (cond + ((and window-system proof-running-on-XEmacs (featurep 'jpeg) (not nojpeg) + (funcall validfn jpg)) + jpg) + ((and window-system proof-running-on-XEmacs (featurep 'gif) (funcall validfn gif)) + gif) + ((and window-system proof-running-on-XEmacs (featurep 'xpm) (funcall validfn xpm)) + xpm) + ;; Support GNU Emacs 21 + ((and + proof-running-on-Emacs21 + (setq img + (find-image + (list + (list :type 'jpeg + :file (concat proof-images-directory name ".jpg")) + (list :type 'gif + :file (concat proof-images-directory name ".gif")) + (list :type 'xpm + :file (concat proof-images-directory name ".xpm")))))) + img) + (t + (or default (concat "[ image " name " ]")))))) + +;; Would be nice to get rid of this variable, but it's tricky +;; to construct a hook function, with a higher order function, +;; which can easily remove itself. +(defvar proof-splash-timeout-conf nil + "Holds timeout ID and previous window config for proof splash screen.") + +(defun proof-splash-centre-spaces (glyph) + "Return number of spaces to insert in order to center given GLYPH or string. +Borrowed from startup-center-spaces." + (let* ((avg-pixwidth (round (/ (frame-pixel-width) (frame-width)))) + (fill-area-width (* avg-pixwidth (- fill-column left-margin))) + (glyph-pixwidth (cond ((stringp glyph) + (* avg-pixwidth (length glyph))) + ((and (fboundp 'glyphp) + (glyphp glyph)) + (glyph-width glyph)) + ((proof-emacs-imagep glyph) + (car (image-size glyph 'inpixels))) + (t + (error + "proof-splash-centre-spaces: bad arg"))))) + (+ left-margin + (round (/ (/ (- fill-area-width glyph-pixwidth) 2) avg-pixwidth))))) + +;; We take some care to preserve the users window configuration +;; underneath the splash screen. This is just to be polite. +;; FIXME: not as polite as it could be: if minibuffer is active, +;; this may deactivate it. +(defun proof-splash-remove-screen (conf) + "Remove splash screen and restore window config to CONF." + (let + ((splashbuf (get-buffer proof-splash-welcome))) + (if splashbuf + (progn + (if (and conf (get-buffer-window splashbuf)) + ;; Restore the window config if splash is being displayed + (progn + (kill-buffer splashbuf) + (set-window-configuration conf) + (if proof-running-on-XEmacs + (redraw-frame nil t))) + (kill-buffer splashbuf)))))) + +(defvar proof-splash-seen nil + "Flag indicating the user has been subjected to a welcome message.") + +;;;###autoload +(defun proof-splash-display-screen (&optional timeout) + "Save window config and display Proof General splash screen. +If TIMEOUT is non-nil, time out outside this function, definitely +by end of configuring proof mode. +Otherwise, timeout inside this function after 10 seconds or so." + (interactive "P") + (let* + ;; Keep win config explicitly instead of pushing/popping because + ;; if the user switches windows by hand in some way, we want + ;; to ignore the saved value. Unfortunately there seems to + ;; be no way currently to remove the top item of the stack. + ((winconf (current-window-configuration)) + (curwin (get-buffer-window (current-buffer))) + (curfrm (and curwin (window-frame curwin))) + (splashbuf (get-buffer-create proof-splash-welcome)) + (after-change-functions nil) ; no font-lock, thank-you. + ;; NB: maybe leave next one in for frame-crazy folk + ;;(pop-up-frames nil) ; display in the same frame. + (splash-contents (append + (eval proof-splash-contents) + (eval proof-splash-startup-msg))) + s) + (with-current-buffer splashbuf + (erase-buffer) + ;; [ Don't use do-list to avoid loading cl ] + (while splash-contents + (setq s (car splash-contents)) + (cond + ((and proof-running-on-XEmacs + (vectorp s) + (valid-instantiator-p s 'image)) + (let ((gly (make-glyph s))) + (indent-to (proof-splash-centre-spaces gly)) + (set-extent-begin-glyph (make-extent (point) (point)) gly))) + ((proof-emacs-imagep s) + (indent-to (proof-splash-centre-spaces s)) + (insert-image s)) + ((stringp s) + (indent-to (proof-splash-centre-spaces s)) + (insert s))) + (newline) + (setq splash-contents (cdr splash-contents))) + (goto-char (point-min)) + (set-buffer-modified-p nil) + (let* ((splashwin (display-buffer splashbuf)) + (splashfm (window-frame splashwin)) + ;; Only save window config if we're on same frame + (savedwincnf (if (eq curfrm splashfm) winconf))) + (delete-other-windows splashwin) + (if (fboundp 'redisplay-frame) + (redisplay-frame nil t) ; XEmacs special + (sit-for 0)) + (setq proof-splash-timeout-conf + (cons + (add-timeout (if timeout proof-splash-time 10) + 'proof-splash-remove-screen + winconf) + savedwincnf)))) + ;; PROBLEM: when to call proof-splash-display-screen? + ;; We'd like to call it during loading/initialising. But it's + ;; hard to make the screen persist after loading because of the + ;; action of display-buffer invoked after the mode function + ;; during find-file. + ;; To approximate the best behaviour, we assume that this file is + ;; loaded by a call to proof-mode. We display the screen now and add + ;; a wait procedure temporarily to proof-mode-hook which prevents + ;; redisplay until proof-splash-time has elapsed. + (if timeout + (add-hook 'proof-mode-hook 'proof-splash-timeout-waiter) + ;; Otherwise, this was an "about" type of call, so we wait + ;; for a key press or timeout event + (proof-splash-timeout-waiter)) + (setq proof-splash-seen t))) + +;;;###autoload +(defun proof-splash-message () + "Make sure the user gets welcomed one way or another." + (interactive) + (unless (or proof-splash-seen (noninteractive)) + (if proof-splash-enable + (proof-splash-display-screen (not (interactive-p))) + ;; Otherwise, a message + (message "Welcome to %s Proof General!" proof-assistant)) + (setq proof-splash-seen t))) + +(defun proof-splash-timeout-waiter () + "Wait for proof-splash-timeout or input, then remove self from hook." + (while (and (get-buffer proof-splash-welcome) + (not (input-pending-p))) + (if proof-running-on-XEmacs + (sit-for 0 t) ; XEmacs: wait without redisplay + ; (sit-for 1 0 t))) ; FSF: NODISP arg seems broken + (sit-for 0))) + (if (get-buffer proof-splash-welcome) + (proof-splash-remove-screen (cdr proof-splash-timeout-conf))) + ;; Make sure timeout is stopped + (disable-timeout (car proof-splash-timeout-conf)) + (if (and (input-pending-p) + (fboundp 'next-command-event)) ; 3.3: this function + ; disappeared from emacs, sigh + (setq unread-command-events + (cons (next-command-event) unread-command-events))) + (remove-hook 'proof-mode-hook 'proof-splash-timeout-waiter)) + +(provide 'proof-splash) +;; End of proof-splash. diff --git a/generic/proof-syntax.el b/generic/proof-syntax.el new file mode 100644 index 00000000..72848f64 --- /dev/null +++ b/generic/proof-syntax.el @@ -0,0 +1,275 @@ +;; proof-syntax.el Functions for dealing with syntax +;; +;; Copyright (C) 1997-2001 LFCS Edinburgh. +;; Authors: David Aspinall, Healfdene Goguen, +;; Thomas Kleymann, Dilip Sequiera +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; + +(require 'font-lock) +(require 'proof-config) + +;; FIXME da: would regexp-opt be better here? Or maybe +;; (concat "\\<" (regexp-opt l) "\\>") +(defun proof-ids-to-regexp (l) + "Maps a non-empty list of tokens `l' to a regexp matching any element" + (mapconcat (lambda (s) (concat "\\<" s "\\>")) l "\\|")) + +(defun proof-anchor-regexp (e) + "Anchor (\\`) and group the regexp E." + (concat "\\`\\(" e "\\)")) + +(defconst proof-no-regexp + "\\'\\`" + "A regular expression that never matches anything") + + +(defun proof-regexp-alt (&rest args) + "Return the regexp which matches any of the regexps ARGS." + ;; Is this not available in some library? + (let ((res "")) + (dolist (regexp args) + (setq res (concat res (if (string-equal res "") "\\(" "\\|\\(") + regexp "\\)"))) + res)) + +(defun proof-regexp-region (start end) + "Return regexp matching START anything over several lines END." + ;; FIXME: would like to use shy grouping here \\(?: but it seems + ;; buggy or unimplemented in XEmacs. + ;; WARNING: this produces nasty regexps that lead to stack + ;; overflows. It's better to have a loop that searches over lines, + ;; see next function. + (concat "\\(" start "\\)\\(\n\\|.\\)*\\(" end "\\)")) + +(defun proof-re-search-forward-region (startre endre) + "Search for a region delimited by regexps STARTRE and ENDRE. +Return the start position of the match for STARTRE, or +nil if a region cannot be found." + (if (re-search-forward startre nil t) + (let ((start (match-beginning 0))) + (if (re-search-forward endre nil t) + start)))) + +;; Functions for string matching and searching that take into account +;; value of proof-case-fold-search. Last arg to string-match is not +;; applicable. + +(defun proof-re-search-forward (regexp &optional bound noerror count) + "Like re-search-forward, but set case-fold-search to proof-case-fold-search." + (let + ((case-fold-search proof-case-fold-search)) + (re-search-forward regexp bound noerror count))) + +(defun proof-re-search-backward (regexp &optional bound noerror count) + "Like re-search-backward, but set case-fold-search to proof-case-fold-search." + (let + ((case-fold-search proof-case-fold-search)) + (re-search-backward regexp bound noerror count))) + +(defun proof-string-match (regexp string &optional start) + "Like string-match, but set case-fold-search to proof-case-fold-search." + (let + ((case-fold-search proof-case-fold-search)) + (string-match regexp string start))) + +(defun proof-string-match-safe (regexp string &optional start) + "Like proof-string-match, but return nil if REGEXP or STRING is nil." + (if (and regexp string) (proof-string-match regexp string start))) + +(defun proof-stringfn-match (regexp-or-fn string) + "Like proof-string-match if first arg is regexp, otherwise call it." + (cond ((stringp regexp-or-fn) + (proof-string-match regexp-or-fn string)) + ((functionp regexp-or-fn) + (funcall regexp-or-fn string)))) + +(defun proof-looking-at (regexp) + "Like looking-at, but set case-fold-search to proof-case-fold-search." + (let + ((case-fold-search proof-case-fold-search)) + (looking-at regexp))) + +(defun proof-looking-at-safe (regexp) + "Like proof-looking-at, but return nil if REGEXP is nil." + (if regexp (proof-looking-at regexp))) + +(defun proof-looking-at-syntactic-context () + "Determine if current point is at beginning or within comment/string context. +If so, return non-nil." + (or + (proof-buffer-syntactic-context) + (proof-looking-at-safe proof-script-comment-start-regexp) + (proof-looking-at-safe proof-string-start-regexp))) + + + +;; Replacing matches + +(defun proof-replace-string (string to-string) + "Non-interactive version of `replace-string', which see." + (while (search-forward string nil t) + (replace-match to-string nil t))) + +(defun proof-replace-regexp (regexp to-string) + "Non-interactive version of `replace-regexp', which see." + (while (re-search-forward regexp nil t) + (replace-match to-string nil nil))) + + +;; Generic font-lock + +(defvar proof-id "\\(\\w\\(\\w\\|\\s_\\)*\\)" + "A regular expression for parsing identifiers.") + +;; For font-lock, we treat ,-separated identifiers as one identifier +;; and refontify commata using \{proof-zap-commas}. + +(defun proof-ids (proof-id &optional sepregexp) + "Generate a regular expression for separated lists of identifiers. +Default is comma separated, or SEPREGEXP if set." + (concat proof-id "\\(\\s-*" (or sepregexp ",") "\\s-*" + proof-id "\\)*")) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; A function to unfontify commas in declarations and definitions. +;; Useful for provers which have declarations of the form x,y,z:Ty +;; All that can be said for it is that the previous ways of doing +;; this were even more bogus.... + +(defun proof-zap-commas (limit) + "Remove the face of all `,' from point to LIMIT. +Meant to be used from `font-lock-keywords'." + (while (search-forward "," limit t) + (if (memq (get-text-property (1- (point)) 'face) + '(proof-declaration-name-face + font-lock-variable-name-face + font-lock-function-name-face)) + (put-text-property (1- (point)) (point) 'face nil)))) + +;; +;; Functions for doing something like "format" but with customizable +;; control characters. +;; +;; Added for version 3.1 to help quote funny characters in filenames. +;; + +;;;###autoload +(defun proof-format (alist string) + "Format a string by matching regexps in ALIST against STRING. +ALIST contains (REGEXP . REPLACEMENT) pairs where REPLACEMENT +may be a string or sexp evaluated to get a string." + (while alist + (let ((idx 0)) + (while (string-match (car (car alist)) string idx) + (setq string + (concat (substring string 0 (match-beginning 0)) + (cond + ((stringp (cdr (car alist))) + (cdr (car alist))) + (t + (eval (cdr (car alist))))) + (substring string (match-end 0)))) + (setq idx (+ (match-beginning 0) (length (cdr (car alist))))))) + (setq alist (cdr alist))) + string) + +(defun proof-format-filename (string filename) + "Format STRING by replacing quoted chars by escaped version of FILENAME. + +%e uses the canonicalized expanded version of filename (including +directory, using default-directory -- see `expand-file-name'). + +%r uses the unadjusted (possibly relative) version of FILENAME. + +%m ('module') uses the basename of the file, without directory +or extension. + +%s means the same as %e. + +Using %e can avoid problems with dumb proof assistants who don't +understand ~, for example. + +For all these cases, the escapes in `proof-shell-filename-escapes' +are processed. + +If STRING is in fact a function, instead invoke it on FILENAME and +return the resulting (string) value." + (cond + ((functionp string) + (funcall string filename)) + (t + (proof-format + (list (cons "%s" (proof-format proof-shell-filename-escapes + (expand-file-name filename))) + (cons "%e" (proof-format proof-shell-filename-escapes + (expand-file-name filename))) + (cons "%r" (proof-format proof-shell-filename-escapes + filename)) + (cons "%m" (proof-format proof-shell-filename-escapes + (file-name-nondirectory + (file-name-sans-extension filename))))) + string)))) + + +;; +;; Functions for inserting text into buffer. +;; +;; Added for version 3.2 to provide more prover specific shortcuts. +;; + +; Taken from Isamode +; +; %l - insert the value of isa-logic-name +; %s - insert the value returned by isa-current-subgoal + +(defun proof-insert (text) + "Insert TEXT into the current buffer. +TEXT may include these special characters: + %p - place the point here after input +Any other %-prefixed character inserts itself." + ; would be quite nice to have this function: + ;(isa-delete-pending-input) + (let ((i 0) pos acc) + (while (< i (length text)) + (let ((ch (elt text i))) + (if (not (eq ch ?%)) + (setq acc (concat acc (char-to-string ch))) + (setq i (1+ i)) + (setq ch (elt text i)) + (cond ;((eq ch ?l) + ; (setq acc (concat acc isa-logic-name))) + ;((eq ch ?s) + ; (setq acc + ; (concat acc + ; (int-to-string + ; (if (boundp 'isa-denoted-subgoal) + ; isa-denoted-subgoal + ; 1))))) + ;((eq ch ?n) + ; (if acc (insert acc)) + ; (setq acc nil) + ; (comint-send-input)) + ((eq ch ?p) + (if acc (insert acc)) + (setq acc nil) + (setq pos (point))) + (t (setq acc (concat acc (char-to-string ch))))))) + (setq i (1+ i))) + (if acc (insert acc)) + (if pos (goto-char pos)))) + +(defun proof-splice-separator (sep strings) + "Splice SEP into list of STRINGS." + (let (stringsep) + (while strings + (setq stringsep (concat stringsep (car strings))) + (setq strings (cdr strings)) + (if strings (setq stringsep + (concat stringsep sep)))) + stringsep)) + +(provide 'proof-syntax) diff --git a/generic/proof-system.el b/generic/proof-system.el new file mode 100644 index 00000000..c5124ee6 --- /dev/null +++ b/generic/proof-system.el @@ -0,0 +1,20 @@ +;; proof-system.el Proof General functions for interfacing with proof system. +;; +;; Copyright (C) 2000 LFCS Edinburgh. +;; Author: David Aspinall <da@dcs.ed.ac.uk> +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; New in 3.2. This file contains code for communicating settings +;; maintained in Proof General with the underlying proof system, +;; and code for buiding useful prover specific commands. +;; + +(require 'proof-config) + +;; Ooops! Nothing here now. Now in proof-menu.el + + +;; End of proof-system.el +(provide 'proof-system)
\ No newline at end of file diff --git a/generic/proof-toolbar.el b/generic/proof-toolbar.el new file mode 100644 index 00000000..aa658bf3 --- /dev/null +++ b/generic/proof-toolbar.el @@ -0,0 +1,588 @@ +;; proof-toolbar.el Toolbar for Proof General +;; +;; Copyright (C) 1998,9 David Aspinall / LFCS. +;; Author: David Aspinall <da@dcs.ed.ac.uk> +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; NB: FSF GNU Emacs has no toolbar facility. This file defines +;; proof-toolbar-menu which holds the same commands and is put on the +;; menubar by proof-toolbar-setup (perhaps surprisingly). +;; Could consider moving the generic table stuff to proof-menu now. +;; +;; Toolbar is just for the scripting buffer, currently. +;; +;; +;; TODO (minor things): +;; +;; 1. edit-toolbar cannot edit proof toolbar (even in a proof mode) +;; Need a variable containing a specifier or similar. +;; (defvar proof-toolbar-specifier nil +;; "Specifier for proof toolbar.") +;; This doesn't seem worth fixing until XEmacs toolbar implementation +;; settles a bit. Enablers don't work too well at the moment. + +;; 2. It's a little bit tricky to add prover-specific items: +;; presently it must be done before this file is loaded. +;; We could improve on that by generating everything on-thy-fly +;; in proof-toolbar-setup. + +;; 3. We could consider automatically disabling buttons which are +;; not configured for the prover, e.g. if proof-info-command is +;; not set, then the Info button should not be shown. + + +;;; IMPORT declaration (only to suppress warnings for byte compile) +;;; NB: can't put require proof-script here: leads to circular +;;; requirement via proof-menu. +;; (require 'proof-script) +;; (autoload 'proof-shell-live-buffer "proof-shell") +;; (autoload 'proof-shell-restart "proof-shell") + + +(require 'proof-config) ; for <PA>-toolbar-entries + +;; +;; See `proof-toolbar-entries-default' and +;; `<PA>-toolbar-entries' in proof-config +;; for the default generic toolbar and +;; the per-prover toolbar contents variable. +;; + +;; +;; Function, icon, button names +;; + +(defun proof-toolbar-function (token) + (intern (concat "proof-toolbar-" (symbol-name token)))) + +(defun proof-toolbar-icon (token) + (intern (concat "proof-toolbar-" (symbol-name token) "-icon"))) + +(defun proof-toolbar-enabler (token) + (intern (concat "proof-toolbar-" (symbol-name token) "-enable-p"))) + +(defun proof-toolbar-function-with-enabler (token) + (intern (concat "proof-toolbar-" (symbol-name token) "-with-enabler-p"))) + +;; +;; Now the toolbar icons and buttons +;; + +(defun proof-toolbar-make-icon (tle) + "Make icon variable and icon list entry from a PA-toolbar-entries entry." + (let* ((icon (car tle)) + (tooltip (nth 2 tle)) + (iconname (symbol-name icon)) + (iconvar (proof-toolbar-icon icon))) + ;; first declare variable + ;; (eval + ;; `(defvar ,iconvar nil + ;; ,(concat + ;; "Glyph list for " iconname " button in Proof General toolbar."))) + ;; FIXME: above doesn't quite work right. However, we only lose + ;; the docstring which is no big deal. + ;; now the list entry + (if tooltip + (list (list iconvar iconname))))) + + +(defun proof-toolbar-make-toolbar-item (tle) + "Make a toolbar button descriptor from a PA-toolbar-entries entry." + (let* + ((token (nth 0 tle)) + (includep (or (< (length tle) 5) (eval (nth 4 tle)))) + (menuname (and includep (nth 1 tle))) + (tooltip (and includep (nth 2 tle))) + (existsenabler (nth 3 tle)) + (enablep (and proof-toolbar-use-button-enablers + (>= emacs-major-version 21) + existsenabler)) + (enabler (proof-toolbar-enabler token)) + (enableritem (if enablep (list enabler) t)) + (buttonfn (proof-toolbar-function token)) + (buttonfnwe (proof-toolbar-function-with-enabler token)) + (icon (proof-toolbar-icon token)) + (actualfn + (if (or enablep (not existsenabler)) + buttonfn + ;; Add the enabler onto the function if necessary. + (eval `(defun ,buttonfnwe () + (interactive) + (if (,enabler) + (call-interactively (quote ,buttonfn)) + (message "Button \"%s\" disabled" ,menuname)))) + buttonfnwe))) + (if tooltip ;; no tooltip means menu-only item + (if proof-running-on-XEmacs + (list (vector icon actualfn enableritem tooltip)) + (list (append (list icon actualfn token + :help tooltip) + (if enabler (list :enable (list enabler))))))))) + + + +;; +;; Code for displaying and refreshing toolbar +;; + +(defvar proof-toolbar nil + "Proof mode toolbar button list. Set in proof-toolbar-build. +For GNU Emacs, this holds a keymap.") + +(deflocal proof-toolbar-itimer nil + "itimer for updating the toolbar in the current buffer") + +;;;###autoload +(defun proof-toolbar-setup () + "Initialize Proof General toolbar and enable it for current buffer. +If proof-mode-use-toolbar is nil, change the current buffer toolbar +to the default toolbar." + (interactive) + (if + (and ;; Check support in Emacs + (or (and (featurep 'tool-bar) ; GNU Emacs tool-bar library + (member 'xpm image-types)) ; and XPM support + (and (featurep 'toolbar) ; or XEmacs toolbar library + (featurep 'xpm))) ; and XPM support + ;; Check support in Window system + (memq (if proof-running-on-XEmacs (console-type) window-system) + '(x mswindows gtk))) + + ;; Toolbar support is possible. + (progn + ;; Check the toolbar has been built. + (or proof-toolbar (proof-toolbar-build)) + + ;; Now see if user wants toolbar + ;; or not (this can be changed dyamically). + (if proof-toolbar-enable + + ;; Enable the toolbar in this buffer + (if proof-running-on-Emacs21 + ;; For GNU Emacs, we make a local tool-bar-map + (set (make-local-variable 'tool-bar-map) proof-toolbar) + + ;; For XEmacs, we set the toolbar specifier for this buffer. + (set-specifier default-toolbar proof-toolbar (current-buffer)) + ;; We also setup refresh hackery + (proof-toolbar-setup-refresh)) + + ;; Disable the toolbar in this buffer + (if proof-running-on-Emacs21 + ;; For GNU Emacs, we remove local value of tool-bar-map + (kill-local-variable 'tool-bar-map) + ;; For XEmacs, we remove specifier and disable refresh. + (remove-specifier default-toolbar (current-buffer)) + (proof-toolbar-disable-refresh))) + + ;; Update the display + (sit-for 0)))) + +(defun proof-toolbar-build () + "Build proof-toolbar." + (let + ((icontype (if (and (boundp 'device-pixel-depth) + (< (device-pixel-depth) 16)) + ;; Select 8bit xpm's if we've got a + ;; limited colour depth. + ".8bit.xpm" ".xpm")) + + (proof-toolbar-icon-list + ;; List of icon variable names and their associated image + ;; files. A list of lists of the form (VAR IMAGE). IMAGE is + ;; the root name for ;an image file in proof-images-directory. + ;; The toolbar code expects to find files IMAGE.xpm or + ;; IMAGE.8bit.xpm and chooses the best one for the display + ;; properites. + (apply 'append + (mapcar 'proof-toolbar-make-icon + (proof-ass toolbar-entries)))) + + (proof-toolbar-button-list + ;; A toolbar descriptor evaluated in proof-toolbar-setup. + ;; Specifically, a list of sexps which evaluate to entries in + ;; a toolbar descriptor. The default value + ;; proof-toolbar-default-button-list will work for any proof + ;; assistant. + (append + (apply 'append (mapcar 'proof-toolbar-make-toolbar-item + (proof-ass toolbar-entries))) + (if proof-running-on-XEmacs + (list [:style 3d]))))) + + ;; First set the button variables to glyphs. + ;; (NB: this is a bit long-winded). + (mapcar + (lambda (buttons) + (let ((var (car buttons)) + (iconfiles (mapcar (lambda (name) + (concat proof-images-directory + name + icontype)) (cdr buttons)))) + (set var + (if proof-running-on-XEmacs + ;; On XEmacs, icon variable holds a list of glyphs + (toolbar-make-button-list iconfiles) + ;; On GNU emacs, it holds a filename for the icon, + ;; without path or extension. + (eval (cadr buttons)))))) + proof-toolbar-icon-list) + + (if proof-running-on-XEmacs + ;; For XEmacs, we evaluate the specifier. + (setq proof-toolbar (mapcar 'eval proof-toolbar-button-list)) + + ;; On GNU emacs, we need to make a new "key"map, + ;; and set a local copy of tool-bar-map to it. + (setq proof-toolbar (make-sparse-keymap)) + (let ((tool-bar-map proof-toolbar) + (load-path (list proof-images-directory))) ; for finding images + (dolist (but proof-toolbar-button-list) + (apply + 'tool-bar-add-item + (eval (nth 0 but)) ; image filename + (nth 1 but) ; function symbol + (nth 2 but) ; dummy key + (nthcdr 3 but))))) ; remaining properties + ;; Finished + )) + + +;; Action to take after altering proof-toolbar-enable +(defalias 'proof-toolbar-enable 'proof-toolbar-setup) +(proof-deftoggle proof-toolbar-enable proof-toolbar-toggle) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Toolbar refresh functions (hackery for XEmacs) +;; + +(defun proof-toolbar-setup-refresh () + "Enable the XEmacs hackery to update the toolbar." + (if proof-toolbar-use-button-enablers + (progn + ;; Set the callback for updating the enablers + (add-hook 'proof-state-change-hook 'proof-toolbar-refresh) + ;; Also call it whenever text changes in this buffer, + ;; provided it's a script buffer. + (if (eq proof-buffer-type 'script) + (add-hook 'after-change-functions + 'proof-toolbar-refresh nil t)) + ;; And the interval timer for really refreshing the toolbar + (setq proof-toolbar-itimer + (start-itimer "proof toolbar refresh" + 'proof-toolbar-really-refresh + 0.5 ; seconds of delay + 0.5 ; repeated + t ; count idle time + t ; pass argument + (current-buffer)))))) + +(defun proof-toolbar-disable-refresh () + "Disable the XEmacs hackery to update the toolbar." + (remove-hook 'proof-state-change-hook 'proof-toolbar-refresh) + (remove-hook 'after-change-functions 'proof-toolbar-refresh) + (if proof-toolbar-itimer (delete-itimer proof-toolbar-itimer)) + (setq proof-toolbar-itimer nil)) + +(deflocal proof-toolbar-refresh-flag nil + "Flag indicating that the toolbar should be refreshed.") + +;; &rest args needed for after change function args +;; FIXME: don't want to do this in every buffer, really; +;; we'll have proof-toolbar-refresh-flag defined everywhere. +(defun proof-toolbar-refresh (&rest args) + "Set flag to indicate that the toolbar should be refreshed." + (setq proof-toolbar-refresh-flag t)) + +(defvar proof-toolbar-enablers + (mapcar (lambda (tle) + (list (proof-toolbar-enabler (car tle)))) + (proof-ass toolbar-entries)) + "List of all toolbar's enablers") + +(defvar proof-toolbar-enablers-last-state + nil + "Last state of the toolbar's enablers") + +(defun proof-toolbar-really-refresh (buf) + "Force refresh of toolbar display to re-evaluate enablers. +This function needs to be called anytime that enablers may have +changed state." + (if ;; Be careful to only add to correct buffer, and if it's live + (buffer-live-p buf) + (let ((enabler-state (mapcar 'eval proof-toolbar-enablers))) + (if + (not (equal enabler-state proof-toolbar-enablers-last-state)) + (progn + (setq proof-toolbar-enablers-last-state enabler-state) + ;; The official way to do this should be + ;; (set-specifier-dirty-flag default-toolbar) + ;; but it doesn't work, so we do what VM does instead, + ;; removing and re-adding. + (remove-specifier default-toolbar buf) + (set-specifier default-toolbar proof-toolbar buf) + ;; We set the dirty flag as well just in case it helps... + (set-specifier-dirty-flag default-toolbar) + (setq proof-toolbar-refresh-flag nil)))) + ;; Kill off this itimer if it's owning buffer has died + (delete-itimer current-itimer))) + +;; +;; ================================================================= +;; +;; +;; GENERIC PROOF TOOLBAR BUTTON FUNCTIONS +;; +;; Defaults functions are provided below for: up, down, restart +;; Code for specific provers may define the symbols below to use +;; the other buttons: next, prev, goal, qed (images are provided). +;; +;; proof-toolbar-next next function +;; proof-toolbar-next-enable enable predicate for next (or t) +;; +;; etc. +;; +;; To add support for more buttons or alter the default +;; images, <PA>-toolbar-entries should be adjusted. +;; See proof-config.el for that. +;; +;; Note that since the toolbar is displayed for goals and response +;; buffers too, enablers and command functions must potentially +;; switch buffer first. +;; +;; + + +;; +;; Undo button +;; + +(defun proof-toolbar-undo-enable-p () + (proof-with-script-buffer + (and (proof-shell-available-p) + (> (proof-unprocessed-begin) (point-min))))) + +(defalias 'proof-toolbar-undo 'proof-undo-last-successful-command) + +;; +;; Delete button (not actually on toolbar) +;; + +(defun proof-toolbar-delete-enable-p () + (proof-with-script-buffer + (and (not buffer-read-only) + (proof-shell-available-p) + (> (proof-unprocessed-begin) (point-min))))) + +(defalias 'proof-toolbar-delete 'proof-undo-and-delete-last-successful-command) + + +;; +;; Lockedend button (not actually on toolbar) +;; + +(defun proof-toolbar-lockedend-enable-p () + t) + +(defalias 'proof-toolbar-lockedend 'proof-goto-end-of-locked) + + + + +;; +;; Next button +;; + +(defun proof-toolbar-next-enable-p () + (proof-with-script-buffer + (not (proof-locked-region-full-p)))) + +(defalias 'proof-toolbar-next 'proof-assert-next-command-interactive) + + +;; +;; Goto button +;; + +(defun proof-toolbar-goto-enable-p () + (eq proof-buffer-type 'script)) + +(defalias 'proof-toolbar-goto 'proof-goto-point) + + +;; +;; Retract button +;; + +(defun proof-toolbar-retract-enable-p () + (proof-with-script-buffer + (not (proof-locked-region-empty-p)))) + +(defalias 'proof-toolbar-retract 'proof-retract-buffer) + + +;; +;; Use button +;; + +(defalias 'proof-toolbar-use-enable-p 'proof-toolbar-next-enable-p) +(defalias 'proof-toolbar-use 'proof-process-buffer) + +;; +;; Restart button +;; + +(defun proof-toolbar-restart-enable-p () + ;; Could disable this unless there's something running. + ;; But it's handy to clearup extents, etc, I suppose. + t) + +(defalias 'proof-toolbar-restart 'proof-shell-restart) + +;; +;; Goal button +;; + +(defun proof-toolbar-goal-enable-p () + ;; Goals are always allowed, provided proof-goal-command is set. + ;; Will crank up process if need be. + ;; (Actually this should only be available when "no subgoals") + proof-goal-command) + + +(defalias 'proof-toolbar-goal 'proof-issue-goal) + + +;; +;; QED button +;; + +(defun proof-toolbar-qed-enable-p () + (proof-with-script-buffer + (and proof-save-command + proof-shell-proof-completed + (proof-shell-available-p)))) + +(defalias 'proof-toolbar-qed 'proof-issue-save) + +;; +;; State button +;; + +(defun proof-toolbar-state-enable-p () + (proof-shell-available-p)) + +(defalias 'proof-toolbar-state 'proof-prf) + +;; +;; Context button +;; + +(defun proof-toolbar-context-enable-p () + (proof-shell-available-p)) + +(defalias 'proof-toolbar-context 'proof-ctxt) + +;; +;; Info button +;; +;; Might as well enable it all the time; convenient trick to +;; start the proof assistant. + +(defun proof-toolbar-info-enable-p () + t) + +(defalias 'proof-toolbar-info 'proof-help) + +;; +;; Command button +;; + +(defun proof-toolbar-command-enable-p () + (proof-shell-available-p)) + +(defalias 'proof-toolbar-command 'proof-minibuffer-cmd) + +;; +;; Help button +;; + +(defun proof-toolbar-help-enable-p () + t) + +(defun proof-toolbar-help () + (interactive) + (info "ProofGeneral")) + +;; +;; Find button +;; + +(defun proof-toolbar-find-enable-p () + (proof-shell-available-p)) + +(defalias 'proof-toolbar-find 'proof-find-theorems) + +;; +;; Visibility button (not on toolbar) +;; + +(defun proof-toolbar-visibility-enable-p () + (span-property-safe (span-at (point) 'type) 'idiom)) + +(defalias 'proof-toolbar-visibility 'pg-toggle-visibility) + +;; +;; Interrupt button +;; + +(defun proof-toolbar-interrupt-enable-p () + proof-shell-busy) + +(defalias 'proof-toolbar-interrupt 'proof-interrupt-process) + + +;; +;; ================================================================= +;; +;; Scripting menu built from toolbar functions +;; + +(defun proof-toolbar-make-menu-item (tle) + "Make a menu item from a PA-toolbar-entries entry." + (let* + ((token (car tle)) + (menuname (cadr tle)) + (tooltip (nth 2 tle)) + (enablep (nth 3 tle)) + (fnname (proof-toolbar-function token)) + ;; fnval: remove defalias to get keybinding onto menu; + ;; NB: function and alias must both be defined for this + ;; to work!! + (fnval (if (symbolp (symbol-function fnname)) + (symbol-function fnname) + fnname))) + (if menuname + (list + (apply 'vector + (append + (list menuname fnval) + (if enablep + (list ':active (list (proof-toolbar-enabler token)))))))))) + +(defconst proof-toolbar-scripting-menu + ;; Toolbar contains commands to manipulate script and + ;; other handy stuff. + (apply 'append + (mapcar 'proof-toolbar-make-menu-item + (proof-ass toolbar-entries))) + "Menu made from the Proof General toolbar commands.") + + +;; +(provide 'proof-toolbar) + diff --git a/generic/proof-utils.el b/generic/proof-utils.el new file mode 100644 index 00000000..da796e2c --- /dev/null +++ b/generic/proof-utils.el @@ -0,0 +1,828 @@ +;; proof-utils.el Proof General utility functions +;; +;; Copyright (C) 1998-2002 LFCS Edinburgh. +;; Author: David Aspinall <da@dcs.ed.ac.uk> and others +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; +;; Loading note: this file is required immediately from proof.el, so +;; no autoloads are used here. + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Handy macros + +(defmacro deflocal (var value &optional docstring) + "Define a buffer local variable VAR with default value VALUE." + `(progn + (defvar ,var nil ,docstring) + (make-variable-buffer-local (quote ,var)) + (setq-default ,var ,value))) + +(defmacro proof-with-current-buffer-if-exists (buf &rest body) + "As with-current-buffer if BUF exists and is live, otherwise nothing." + `(if (buffer-live-p ,buf) + (with-current-buffer ,buf + ,@body))) + +;; Slightly specialized version of above. This is used in commands +;; which work from different PG buffers (goals, response), typically +;; bound to toolbar commands. +(defmacro proof-with-script-buffer (&rest body) + "Execute BODY in some script buffer: current buf or otherwise proof-script-buffer. +Return nil if not a script buffer or if no active scripting buffer." + `(cond + ((eq proof-buffer-type 'script) + (progn + ,@body)) + ((buffer-live-p proof-script-buffer) + (with-current-buffer proof-script-buffer + ,@body)))) + +(defmacro proof-map-buffers (buflist &rest body) + "Do BODY on each buffer in BUFLIST, if it exists." + `(dolist (buf ,buflist) + (proof-with-current-buffer-if-exists buf ,@body))) + +(defmacro proof-sym (string) + "Return symbol for current proof assistant using STRING." + `(intern (concat (symbol-name proof-assistant-symbol) "-" ,string))) + + +(defun proof-try-require (symbol) + "Try requiring SYMBOL. No error if the file for SYMBOL isn't found." + (condition-case () + (require symbol) + (file-error nil)) + (featurep symbol)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Function for taking action when dynamically adjusting customize values +;; +(defun proof-set-value (sym value) + "Set a customize variable using set-default and a function. +We first call `set-default' to set SYM to VALUE. +Then if there is a function SYM (i.e. with the same name as the +variable SYM), it is called to take some dynamic action for the new +setting. + +If there is no function SYM, we try stripping +proof-assistant-symbol and adding \"proof-\" instead to get +a function name. This extends proof-set-value to work with +generic individual settings. + +The dynamic action call only happens when values *change*: as an +approximation we test whether proof-config is fully-loaded yet." + (set-default sym value) + (if (featurep 'proof-config) + (if (fboundp sym) + (funcall sym) + (if (> (length (symbol-name sym)) + (+ 3 (length (symbol-name proof-assistant-symbol)))) + (let ((generic + (intern + (concat "proof" + (substring (symbol-name sym) + (length (symbol-name + proof-assistant-symbol))))))) + (if (fboundp generic) + (funcall generic))))))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Macros for defining per-assistant customization settings. +;; +;; This new mechanism is an improved way to handle per-assistant +;; settings. Instead of declaring a variable +;; "proof-assistant-web-page" and duplicating it in the prover +;; specific code to make the generic setting, we automatically declare +;; "isabelle-web-page", "coq-web-page", etc, using these macros. +;; +;; The advantage of this is that people's save settings will work +;; properly, and that it will become more possible to use more than +;; one instance of PG at a time. The disadvantage is that it is +;; slightly more complicated, and less "object-oriented" than the +;; previous approach. It is also a big change to move all settings. +;; +;; NB: this mechanism is work in progress in 3.2. It will +;; be expanded, although we may leave most low-level +;; settings to use the current mechanism. +;; +;; Notes: +;; +;; Two mechanisms for accessing generic vars: +;; +;; (proof-ass name) or (proof-assistant-name) +;; +;; Later is more efficient, though defining function +;; for each setting seems wasteful? + +(defun proof-ass-symv (sym) + "Return the symbol for SYM for the current prover. SYM is evaluated." + (intern (concat (symbol-name proof-assistant-symbol) "-" + (symbol-name sym)))) + +(defmacro proof-ass-sym (sym) + "Return the symbol for SYM for the current prover. SYM not evaluated." + `(proof-ass-symv (quote ,sym))) + +(defun proof-defpgcustom-fn (sym args) + "Define a new customization variable <PA>-sym for the current proof assistant. +Helper for macro `defpgcustom'." + (let ((specific-var (proof-ass-symv sym)) + (generic-var (intern (concat "proof-assistant-" (symbol-name sym))))) + (eval + `(defcustom ,specific-var + ,@args + ;; FIXME: would be nicer to grab group from @args here and + ;; prefix it automatically. For now, default to internals + ;; setting for PA. + ;; FIXME 2: would also be nice to grab docstring from args + ;; and allow substitution for prover name, etc. A bit too + ;; fancy perhaps! + :group ,(quote proof-assistant-internals-cusgrp))) + ;; For functions, we could simply use defalias. Unfortunately there + ;; is nothing similar for values, so we define a new set/get function. + (eval + `(defun ,generic-var (&optional newval) + ,(concat "Set or get value of " (symbol-name sym) " for current proof assistant. +If NEWVAL is present, set the variable, otherwise return its current value.") + (if newval + (setq ,specific-var newval) + ,specific-var))))) + +(defun undefpgcustom (sym) + (let ((specific-var (proof-ass-symv sym)) + (generic-var (intern (concat "proof-assistant-" (symbol-name sym))))) + (pg-custom-undeclare-variable specific-var) + (fmakunbound generic-var))) + +(defmacro defpgcustom (sym &rest args) + "Define a new customization variable <PA>-SYM for the current proof assistant. +The function proof-assistant-<SYM> is also defined, which can be used in the +generic portion of Proof General to set and retrieve the value for the current p.a. +Arguments as for `defcustom', which see. + +Usage: (defpgcustom SYM &rest ARGS)." + `(proof-defpgcustom-fn (quote ,sym) (quote ,args))) + +(defmacro proof-ass (sym) + "Return the value for SYM for the current prover." + ;; (eval `(proof-ass-sym ,sym)) + `(symbol-value (proof-ass-symv ',sym))) ;; [Stefan Monnier] + +(defun proof-defpgdefault-fn (sym value) + "Helper for `defpgdefault', which see. SYM and VALUE are evaluated." + ;; NB: we need this because nothing in customize library seems to do + ;; the right thing. + (let ((symbol (proof-ass-symv sym))) + (set-default symbol + (cond + ;; Use saved value if it's set + ((get symbol 'saved-value) + (car (get symbol 'saved-value))) + ;; Otherwise override old default with new one + (t + value))))) + +(defmacro defpgdefault (sym value) + "Set default for the proof assistant specific variable <PA>-SYM to VALUE. +This should be used in prover-specific code to alter the default values +for prover specific settings. + +Usage: (defpgdefault SYM VALUE)" + `(proof-defpgdefault-fn (quote ,sym) ,value)) + +;; +;; Make a function named for the current proof assistant. +;; +(defmacro defpgfun (name arglist &rest args) + "Define function <PA>-SYM as for defun." + `(defun ,(proof-ass-symv name) ,arglist + ,@args)) + + +;; +;; End macros +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Buffers and filenames + +(defun proof-file-truename (filename) + "Returns the true name of the file FILENAME or nil if file non-existent." + (and filename (file-exists-p filename) (file-truename filename))) + +(defun proof-file-to-buffer (filename) + "Find a buffer visiting file FILENAME, or nil if there isn't one." + (let* ((buffers (buffer-list)) + (pos + (position (file-truename filename) + (mapcar 'proof-file-truename + (mapcar 'buffer-file-name + buffers)) + :test 'equal))) + (and pos (nth pos buffers)))) + +(defun proof-files-to-buffers (filenames) + "Converts a list of FILENAMES into a list of BUFFERS." + (if (null filenames) nil + (let* ((buffer (proof-file-to-buffer (car filenames))) + (rest (proof-files-to-buffers (cdr filenames)))) + (if buffer (cons buffer rest) rest)))) + +(defun proof-buffers-in-mode (mode &optional buflist) + "Return a list of the buffers in the buffer list in major-mode MODE. +Restrict to BUFLIST if it's set." + (let ((bufs-left (or buflist (buffer-list))) + bufs-got) + (dolist (buf bufs-left bufs-got) + (if (with-current-buffer buf (eq mode major-mode)) + (setq bufs-got (cons buf bufs-got)))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Associated buffers +;; + +(defun pg-save-from-death () + "Prevent this associated buffer from being killed: merely erase it. +A hook function for `kill-buffer-hook'. +This is a fairly crude and not-entirely-robust way to prevent the +user accidently killing an associated buffer." + (if (and (proof-shell-live-buffer) proof-buffer-type) + (progn + (let ((bufname (buffer-name))) + (erase-buffer) + (set-buffer-modified-p nil) + (bury-buffer) + (error + "Warning: buffer %s not killed; still associated with prover process." + bufname))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Key functions + +(defun proof-define-keys (map kbl) + "Adds keybindings KBL in MAP. +The argument KBL is a list of tuples (k . f) where `k' is a keybinding +\(vector) and `f' the designated function." + (mapcar + (lambda (kbl) + (let ((k (car kbl)) (f (cdr kbl))) + (define-key map k f))) + kbl)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Managing font-lock +;; + +;; Notes: +;; +;; * Various mechanisms for setting defaults, different between +;; Emacsen. Old method(?) was to set "blah-mode-font-lock-keywords" +;; and copy it into "font-lock-keywords" to engage font-lock. +;; Present method for XEmacs is to put a 'font-lock-defaults +;; property on the major-mode symbol, or use font-lock-defaults +;; buffer local variable. We use the latter. +;; +;; * Buffers which are output-only are *not* kept in special minor +;; modes font-lock-mode (or x-symbol-mode). In case the user +;; doesn't want fontification we have a user option, +;; proof-output-fontify-enable. + +(deflocal proof-font-lock-keywords nil + "Value of font-lock-keywords in this buffer. +We set `font-lock-defaults' to '(proof-font-lock-keywords t) for +compatibility with X-Symbol, which may hack proof-font-lock-keywords +with extra patterns (in non-mule mode).") + +(deflocal proof-font-lock-keywords-case-fold-search nil + "Value of font-lock-keywords-case-fold-search in this buffer.") + +(defun proof-font-lock-configure-defaults (autofontify &optional case-fold) + "Set defaults for font-lock based on current font-lock-keywords. +This is a delicate operation, because we only want to use font-lock-mode +in some buffers, so we have to tread carefully around the font-lock +code to avoid it turning itself on in the buffers where that actually +*breaks* fontification. + +AUTOFONTIFY must be nil for buffers where we may want to really use +font-lock-mode." + ;; + ;; At the moment, the specific assistant code hacks + ;; font-lock-keywords. Here we use that value to hack + ;; font-lock-defaults, which is used by font-lock to set + ;; font-lock-keywords from again!! Yuk. + ;; + ;; Previously, 'font-lock-keywords was used directly as a setting + ;; for the defaults. This has a bad interaction with x-symbol which + ;; edits font-lock-keywords and loses the setting. So we make a + ;; copy of it in a new local variable, proof-font-lock-keywords. + ;; + (make-local-variable 'proof-font-lock-keywords) + (make-local-variable 'proof-font-lock-keywords-case-fold-search) + (setq proof-font-lock-keywords font-lock-keywords) + (setq proof-font-lock-keywords-case-fold-search case-fold) + ;; Setting font-lock-defaults explicitly is required by FSF Emacs + ;; 20.4's version of font-lock in any case. + + (if autofontify + (progn + (make-local-variable 'font-lock-defaults) ; needed?? + (setq font-lock-defaults `(proof-font-lock-keywords nil ,case-fold)) + ;; 12.1.99: For XEmacs, we must also set the mode property. + ;; This is needed for buffers which are put into font-lock-mode + ;; (rather than fontified by hand). + (put major-mode 'font-lock-defaults font-lock-defaults)) + ;; 11.12.01: Emacs 21 is very eager about turning on font + ;; lock and has hooks all over the place to do it. To make + ;; sure it doesn't happen we have to eradicate all sense of + ;; having any fontification ability. + (proof-font-lock-clear-font-lock-vars) + ;; In fact, this still leaves font-lock switched on! But + ;; hopefully in a useless way. XEmacs has better control + ;; over which modes not to enable it for (although annoying + ;; that it's a custom setting) + (if proof-running-on-XEmacs + (setq font-lock-mode-disable-list + (cons major-mode font-lock-mode-disable-list))))) + +(defun proof-font-lock-clear-font-lock-vars () + (kill-local-variable 'font-lock-defaults) + (kill-local-variable 'font-lock-keywords) + (setq font-lock-keywords nil) + (put major-mode 'font-lock-defaults nil) + ;; Ensure it's switched off, too. + ;; NB: this tends to undo the hard work we've done + ;; by unfontifying, so don't do that now + ;; (font-lock-mode -1)) + ) + +(defun proof-font-lock-set-font-lock-vars () + (setq font-lock-defaults + `(proof-font-lock-keywords + nil + ,proof-font-lock-keywords-case-fold-search)) + (setq font-lock-keywords proof-font-lock-keywords)) + +(defun proof-fontify-region (start end &optional keepspecials) + "Fontify and decode X-Symbols in region START...END. +Fontifies according to the buffer's font lock defaults. +Uses `proof-x-symbol-decode-region' to decode tokens +if X-Symbol is enabled. + +If `pg-use-specials-for-fontify' is set, remove characters +with top bit set after fontifying so they don't spoil cut and paste, +unless KEEPSPECIALS is set to override this. + +Returns new END value." + ;; We fontify first because X-sym decoding changes char positions. + ;; It's okay because x-symbol-decode works even without font lock. + ;; Possible disadvantage is that font lock patterns can't refer + ;; to X-Symbol characters. + ;; NB: perhaps we can narrow within the whole function, but there + ;; was an earlier problem with doing that. + (if proof-output-fontify-enable + (progn + ;; Temporarily set font-lock defaults + (proof-font-lock-set-font-lock-vars) + + ;; Yukky hacks to immorally interface with font-lock + (unless proof-running-on-XEmacs + (font-lock-set-defaults)) + (let ((font-lock-keywords proof-font-lock-keywords)) + (if (and proof-running-on-XEmacs + (>= emacs-major-version 21) + (>= emacs-minor-version 4) + (not font-lock-cache-position)) + (progn + (setq font-lock-cache-position (make-marker)) + (set-marker font-lock-cache-position 0))) + + (save-restriction + (narrow-to-region start end) + (run-hooks 'pg-before-fontify-output-hook) + (setq end (point-max))) + (font-lock-default-fontify-region start end nil)))) + (save-restriction + (narrow-to-region start end) + (run-hooks 'pg-after-fontify-output-hook) + (setq end (point-max))) + (if (and pg-use-specials-for-fontify (not keepspecials)) + (progn + (pg-remove-specials start end) + (setq end (point)))) + (prog1 + ;; Return new end value + (proof-x-symbol-decode-region start end) + (proof-font-lock-clear-font-lock-vars))) + + +(defconst pg-special-char-regexp "[\200-\377]" + "Regexp matching any \"special\" character (top bit set).") + + +(defun pg-remove-specials (&optional start end) + "Remove special characters (with top bit set) in region. +Default to whole buffer. Leave point at END." + (save-restriction + (if (and start end) + (narrow-to-region start end)) + (goto-char (or start (point-min))) + (proof-replace-regexp pg-special-char-regexp "") + (goto-char (point-max)))) + + + +;; FIXME todo: add toggle for fontify region which turns it on/off + +(defun proof-fontify-buffer () + "Call proof-fontify-region on whole buffer." + (proof-fontify-region (point-min) (point-max))) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Messaging and display functions +;; + + +(defun proof-warn-if-unset (tag sym) + "Give a warning (with TAG) if symbol SYM is unbound or nil." + (unless (and (boundp sym) (symbol-value sym)) + (warn "Proof General %s: %s is unset." tag (symbol-name sym)))) + +(defun proof-display-and-keep-buffer (buffer &optional pos) + "Display BUFFER and mark window according to `proof-three-window-mode'. +If optional POS is present, will set point to POS. +Otherwise move point to the end of the buffer. +Ensure that point is visible in window." + (let (window) + (save-excursion + (set-buffer buffer) + ;; Here's a hack: if we're asking to display BUFFER from a + ;; secondary window and the (next) other one is displaying the + ;; script buffer, then we do switch-buffer instead. This means + ;; that goals and response buffer are swapped as expected in + ;; two-pane mode even if either one is used to "drive" the + ;; scripting. + ;; FIXME: would be better to deduce here which buffer + ;; we're displaying, and use get-buffer-window-list to do + ;; something sensible. + (if (and + (not proof-three-window-mode) + (not (eq (next-window) (selected-window))) + (eq (window-buffer (next-window nil 'ignoreminibuf)) + proof-script-buffer)) + (if (eq (selected-window) (minibuffer-window)) + ;; 17.8.01: avoid switching the minibuffer's contents + ;; -- terrrible confusion -- use next-window after + ;; script buffer instead. + ;; (another hack which is mostly right) + (set-window-buffer + (next-window + (car-safe (get-buffer-window-list proof-script-buffer)) + 'ignoreminibuf) buffer) + (set-window-buffer (selected-window) buffer)) + (display-buffer buffer)) + ;; Suggestion: it might be nice to cache the previous + ;; height of the window to attempt to regenerate the + ;; display as the user last had it. (But how to clear + ;; the cache?) + (setq window (get-buffer-window buffer 'visible)) + (set-window-dedicated-p window proof-three-window-mode) + (and window + (save-selected-window + (select-window window) + (if proof-shrink-windows-tofit + ;; NB: actually we also want to expand to fit --- + ;; otherwise the window will adopt to the smallest + ;; sized output for good. + (proof-resize-window-tofit)) + ;; For various reasons, point may get moved around in + ;; response buffer. Attempt to normalise its position. + (goto-char (or pos (point-max))) + (if pos + (beginning-of-line) + (skip-chars-backward "\n\t ")) + ;; Ensure point visible + (or + ;; FIXME: test proof-shrink-windows-tofit here as a + ;; hack to avoid odd/bad behaviour of shrinking + ;; moving window contents beyond start of display + proof-shrink-windows-tofit + (pos-visible-in-window-p (point) window) + (recenter -1))))))) + +(defun proof-clean-buffer (buffer) + "Erase buffer and hide from display if proof-delete-empty-windows set. +Auto deletion only affects selected frame. (We assume that the selected +frame is the one showing the script buffer.)" + (with-current-buffer buffer + (erase-buffer) + (set-buffer-modified-p nil) + (if (eq buffer proof-response-buffer) + (setq pg-response-next-error nil)) ; all error msgs lost! + (if proof-delete-empty-windows + (delete-windows-on buffer t)))) + +(defun proof-message (&rest args) + "Issue the message ARGS in the response buffer and display it." + (pg-response-display-with-face (apply 'concat args)) + (proof-display-and-keep-buffer proof-response-buffer)) + +(defun proof-warning (&rest args) + "Issue the warning ARGS in the response buffer and display it. +The warning is coloured with proof-warning-face." + (pg-response-display-with-face (apply 'concat args) 'proof-warning-face) + (proof-display-and-keep-buffer proof-response-buffer)) + +;; could be a macro for efficiency in compiled code +(defun proof-debug (msg &rest args) + "Issue the debugging message (format MSG ARGS) in the response buffer, display it. +If proof-show-debug-messages is nil, do nothing." + (if proof-show-debug-messages + (progn + (pg-response-display-with-face (concat "PG debug: " + (apply 'format msg args)) + 'proof-debug-message-face) + (proof-display-and-keep-buffer proof-response-buffer)))) + + +;;; A handy utility function used in the "Buffers" menu. +(defun proof-switch-to-buffer (buf &optional noselect) + "Switch to or display buffer BUF in other window unless already displayed. +If optional arg NOSELECT is true, don't switch, only display it. +No action if BUF is nil or killed." + ;; Maybe this needs to be more sophisticated, using + ;; proof-display-and-keep-buffer ? + (and (buffer-live-p buf) + (unless (eq buf (window-buffer (selected-window))) + (if noselect + (display-buffer buf t) + (switch-to-buffer-other-window buf))))) + +;; This is based on `shrink-window-if-larger-than-buffer' from window.el +;; Except that we also allow the window height to *expand* +;; FIXME: this works in a fairly ugly way! +(defun proof-resize-window-tofit (&optional window) + "Shrink the WINDOW to be as small as possible to display its contents. +Do not shrink to less than `window-min-height' lines. +Do nothing if the buffer contains more lines than the present window height, +or if some of the window's contents are scrolled out of view, +or if the window is not the full width of the frame, +or if the window is the only window of its frame." + (interactive) + (or window (setq window (selected-window))) + (save-excursion + (set-buffer (window-buffer window)) + (let* ((n 0) + (test-pos + (- (point-max) + ;; If buffer ends with a newline, ignore it when counting + ;; height unless point is after it. + (if (and (not (eobp)) + (eq ?\n (char-after (1- (point-max))))) + 1 0))) + (mini (frame-property (window-frame window) 'minibuffer)) + ;; Direction of resizing based on whether max position is visible. + (expand (not (pos-visible-in-window-p test-pos window))) + ;; Most window is allowed to grow to + (max-height (/ (frame-height (window-frame window)) + (if proof-three-window-mode 3 2)))) + (if (and (< 1 (let ((frame (selected-frame))) + (select-frame (window-frame window)) + (unwind-protect + (count-windows) + (select-frame frame)))) + ;; check to make sure that the window is the full width + ;; of the frame + (window-leftmost-p window) + (window-rightmost-p window) + ;; The whole buffer must be visible. + (pos-visible-in-window-p (point-min) window) + ;; The frame must not be minibuffer-only. + (not (eq mini 'only))) + (progn + (save-window-excursion + (goto-char (point-min)) + (while (and (window-live-p window) + (if expand + (not (pos-visible-in-window-p test-pos window)) + (pos-visible-in-window-p test-pos window)) + (< n max-height)) + (shrink-window (if expand -1 1) nil window) + (setq n (1+ n)))) + (if (and (not expand) + ;; attempt to get some stability: only shrink if + ;; we're more than two lines too big. + (> n 2)) + (shrink-window (min (1- n) + (- (window-height window) + (1+ window-min-height))) + nil + window) + ;; Always expand the window if necessary. + (shrink-window (- n)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Function for submitting bug reports. +;; + +(defun proof-submit-bug-report () + "Submit an bug report or other report for Proof General." + (interactive) + (require 'reporter) + (let + ((reporter-prompt-for-summary-p + "(Very) brief summary of problem or suggestion: ")) + (reporter-submit-bug-report + "bugs@proofgeneral.org" + "Proof General" + (list 'proof-general-version 'proof-assistant) + nil nil + "[ When reporting a bug, please include a small test case for us to repeat it. + Please also check that it is not already covered in the BUGS files that came with + the distribution, or the latest versions at + http://www.proofgeneral.org/ProofGeneral/BUGS ]"))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Utils for making functions to adjust user settings +;;; + +(defun proof-deftoggle-fn (var &optional othername) + "Define a function <VAR>-toggle for toggling a boolean customize setting VAR. +Args as for the macro `proof-deftoggle', except will be evaluated." + (eval + `(defun ,(if othername othername + (intern (concat (symbol-name var) "-toggle"))) (arg) + ,(concat "Toggle `" (symbol-name var) "'. With ARG, turn on iff ARG>0. +This function simply uses customize-set-variable to set the variable. +It was constructed with `proof-deftoggle-fn'.") + (interactive "P") + (customize-set-variable + (quote ,var) + (if (null arg) (not ,var) + (> (prefix-numeric-value arg) 0)))))) + +(defmacro proof-deftoggle (var &optional othername) + "Define a function VAR-toggle for toggling a boolean customize setting VAR. +The toggle function uses customize-set-variable to change the variable. +OTHERNAME gives an alternative name than the default <VAR>-toggle. +The name of the defined function is returned." + `(proof-deftoggle-fn (quote ,var) (quote ,othername))) + +(defun proof-defintset-fn (var &optional othername) + "Define a function <VAR>-intset for setting an integer customize setting VAR. +Args as for the macro `proof-defintset', except will be evaluated." + (eval + `(defun ,(if othername othername + (intern (concat (symbol-name var) "-intset"))) (arg) + ,(concat "Set `" (symbol-name var) "' to ARG. +This function simply uses customize-set-variable to set the variable. +It was constructed with `proof-defintset-fn'.") + (interactive ,(format "nValue for %s (int, currently %s):" + (symbol-name var) + (symbol-value var))) + (customize-set-variable (quote ,var) arg)))) + +(defmacro proof-defintset (var &optional othername) + "Define a function <VAR>-intset for setting an integer customize setting VAR. +The setting function uses customize-set-variable to change the variable. +OTHERNAME gives an alternative name than the default <VAR>-intset. +The name of the defined function is returned." + `(proof-defintset-fn (quote ,var) (quote ,othername))) + +(defun proof-defstringset-fn (var &optional othername) + "Define a function <VAR>-toggle for setting an integer customize setting VAR. +Args as for the macro `proof-defstringset', except will be evaluated." + (eval + `(defun ,(if othername othername + (intern (concat (symbol-name var) "-stringset"))) (arg) + ,(concat "Set `" (symbol-name var) "' to ARG. +This function simply uses customize-set-variable to set the variable. +It was constructed with `proof-defstringset-fn'.") + (interactive ,(format "sValue for %s (a string): " + (symbol-name var))) + (customize-set-variable (quote ,var) arg)))) + +(defmacro proof-defstringset (var &optional othername) + "The setting function uses customize-set-variable to change the variable. +OTHERNAME gives an alternative name than the default <VAR>-stringset. +The name of the defined function is returned." + `(proof-defstringset-fn (quote ,var) (quote ,othername))) + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Interface to custom lib +;;; + +;; EMACSFIXME: A function that custom ought to provide. +(defun pg-custom-save-vars (&rest variables) + "Save custom vars VARIABLES." + (dolist (symbol variables) + (let ((value (get symbol 'customized-value))) + ;; This code from customize-save-customized adjusts + ;; properties so that custom-save-all will save + ;; the value. + (when value + (put symbol 'saved-value value) + (if (fboundp 'custom-push-theme) ;; XEmacs customize + (custom-push-theme 'theme-value symbol 'user 'set value)) + (put symbol 'customized-value nil)))) + (custom-save-all)) + +;; FIXME: this doesn't do quite same thing as reset button, +;; which *removes* a setting from `custom-set-variables' list +;; in custom.el. Instead, this adds something to a +;; custom-reset-variables list. +(defun pg-custom-reset-vars (&rest variables) + "Reset custom vars VARIABLES to their default values." + ;; FIXME: probably this XEmacs specific + (apply 'custom-reset-variables + (mapcar (lambda (var) (list var 'default)) + variables))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Finding executables +;; + +(defun proof-locate-executable (progname &optional returnnopath extrapath) + ;; XEmacs can search the paths for us. Probably FSF Emacs is too + ;; daft to provide a useful function to do that, and I don't have + ;; the time to waste writing one or trying to find one. + "Search for PROGNAME on PATH. Return the full path to PROGNAME, or nil. +If RETURNNOPATH is non-nil, return PROGNAME even if we can't find a full path. +EXTRAPATH is a list of extra path components" + (or + (cond + ((fboundp 'executable-find) + (let ((exec-path (append exec-path extrapath))) + (executable-find progname))) ;; PG 3.4: try a new Emacs function. + ((fboundp 'locate-file) + (locate-file progname + (append (split-path (getenv "PATH") extrapth)) + (if proof-running-on-win32 '(".exe")) + 1))) + (if returnnopath progname))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Stuff for developing PG, not needed for ordinary users really. +;; [Could consider moving this to a new file `proof-devel.el'] +;; + +(put 'proof-if-setting-configured 'lisp-indent-function 1) +(put 'proof-define-assistant-command 'lisp-indent-function 'defun) +(put 'proof-define-assistant-command-witharg 'lisp-indent-function 'defun) +(put 'defpgcustom 'lisp-indent-function 'defun) + +(defconst proof-extra-fls + (list + (list "^(\\(proof-def\\" + ;; Variable like things + "\\(asscustom)\\|" + ;; Function like things + "\\([^ \t\n\(\)]+\\)" + ;; Any whitespace and declared object. + "[ \t'\(]*" + "\\([^ \t\n\)]+\\)?") + '(1 font-lock-keyword-face) + '(8 (cond ((match-beginning 3) 'font-lock-variable-name-face) + ;; ((match-beginning 6) 'font-lock-type-face) + (t 'font-lock-function-name-face)) + nil t))) + +;; This doesn't work for FSF's font lock, developers should use +;; XEmacs! +(if (boundp 'lisp-font-lock-keywords) ; compatibility hack + (setq lisp-font-lock-keywords + (append proof-extra-fls + lisp-font-lock-keywords))) + +(setq autoload-package-name "proof") +(setq generated-autoload-file "proof-autoloads.el") + +;; End of proof-utils.el +(provide 'proof-utils) diff --git a/generic/proof-x-symbol.el b/generic/proof-x-symbol.el new file mode 100644 index 00000000..a405f187 --- /dev/null +++ b/generic/proof-x-symbol.el @@ -0,0 +1,364 @@ +;; proof-x-symbol.el Support for X-Symbol package +;; +;; Copyright (C) 1998-2002 LFCS Edinburgh +;; Author: David Aspinall <da@dcs.ed.ac.uk> +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; The X-Symbol package is at http://x-symbol.sourceforge.net/ +;; +;; With enormous thanks to David von Oheimb for providing the original +;; patches for using X-Symbol with Isabelle Proof General, and helping +;; to write this file. +;; +;; Ideally this file ought to be standalone so that the X-Symbol mode +;; for particular proof assistants may be used elsewhere (e.g. in +;; document modes), without loading all of Proof General. +;; +;; $Id$ +;; +;; ================================================================= +;; +;; Notes on interacing to X-Symbol. +;; +;; 1. Proof script buffers. +;; Font lock and X-Symbol minor modes are engaged as usual. +;; Rather than using piecemeal enabling of X-Symbol +;; or putting it onto an auto-mode list, we use +;; proof-x-symbol-enable to cleanly turn on/off +;; X-Symbol in all PG buffers. +;; +;; 2. Output buffers (goals, response, tracing) +;; Neither font-lock nor X-Symbol mode is engaged. +;; Instead, we simply set `x-symbol-language', and call +;; `x-symbol-decode' or `x-symbol-decode-region', via +;; `proof-fontify-region' (which see). +;; + + +(defvar proof-x-symbol-initialized nil + "Non-nil if x-symbol support has been initialized.") + +;;; ###autoload +(defun proof-x-symbol-support-maybe-available () + "A test to see whether x-symbol support may be available." + (and window-system ; Not on a tty + (condition-case () + (require 'x-symbol-hooks) + (t (featurep 'x-symbol-hooks))))) + + +(defun proof-x-symbol-initialize (&optional error) + "Initialize x-symbol support for Proof General, if possible. +If ERROR is non-nil, give error on failure, otherwise a warning." + (interactive) + ; (unless proof-x-symbol-initialized + (let* + ((xs-lang (proof-ass x-symbol-language)) + (xs-lang-name (symbol-name xs-lang)) + (xs-feature (concat "x-symbol-" xs-lang-name)) + (xs-feature-sym (intern xs-feature)) + (error-or-warn + (lambda (str) (if error (error str) (warn str))))) + ;; Check that support is provided. + (cond + ;; + ;; First, some checks on x-symbol. + ;; + ((and (not (featurep 'x-symbol)) + (not (proof-try-require 'x-symbol))) + (funcall error-or-warn + "Proof General: x-symbol package must be installed for x-symbol-support! +The package is available at http://x-symbol.sourceforge.net/")) + ((not window-system) + (funcall error-or-warn + "Proof General: x-symbol package only runs under a window system!")) + ((or (not (fboundp 'x-symbol-initialize)) + (not (fboundp 'x-symbol-register-language))) + (funcall error-or-warn + "Proof General: x-symbol package installation faulty!")) + ;; + ;; Now check proof assistant has support provided + ;; + ;; FIXME: maybe we should let x-symbol load the feature, in + ;; case it uses x-symbol stuff inside. + ;; Is there an easy way of testing for library exists? + ((not (proof-try-require xs-feature-sym)) + (funcall error-or-warn + (format + "Proof General: for x-symbol support, you must provide a library %s.el" + xs-feature))) + (t + ;; We've got everything we need! So initialize. + (require 'x-symbol-vars) ;; [new requirement to require this] + (let* + ((xs-xtra-modes proof-xsym-extra-modes) + (xs-std-modes (list + ;; NB: there is a problem with + ;; initialization order here, these + ;; variables are set in script/shell + ;; mode initialization. They ought to + ;; be set earlier, and enforced as part + ;; of the generic scheme. For the time + ;; being, we use default constructed + ;; names [which every prover should + ;; follow] + (or proof-mode-for-shell + (intern (concat assistant "-shell-mode"))) + (or proof-mode-for-response + (intern (concat assistant "-response-mode"))) + (or proof-mode-for-script + ;; FIXME: next one only correct for isabelle + (intern (concat assistant "-proofscript-mode"))) + (or proof-mode-for-goals + (intern (concat assistant "-goals-mode"))))) + (all-xs-modes (append xs-std-modes xs-xtra-modes)) + (am-entry (list proof-xsym-extra-modes t + `(quote ,xs-lang))) + (symmode-nm (concat xs-lang-name "sym-mode")) + (symmode (intern symmode-nm)) + (symnamevar (intern (concat xs-feature "-name"))) + (symname (concat (capitalize xs-lang-name) " Symbols")) + (symmodelinevar (intern (concat xs-feature "-modeline-name"))) + (symmodelinenm xs-lang-name) + (flks proof-xsym-font-lock-keywords)) + + + (x-symbol-initialize) ;; No harm in doing this multiple times + ;; Set default name and modeline indicator for the symbol + ;; minor mode + (set symnamevar symname) + (set symmodelinevar symmodelinenm) + (x-symbol-register-language xs-lang xs-feature-sym all-xs-modes) + ;; Put the extra modes on the auto-mode-alist + ;; (if xs-xtra-modes (push am-entry x-symbol-auto-mode-alist)) + ;; Okay, let's be less rash and put it on a hook list. + ;; 12.1.00: Nope, there's a problem here! + ;; Results in thy-mode invoking + ;; proof-x-symbol-mode twice, first via hook, then + ;; from proof-config-done-related, which blasts + ;; font-lock-keywords (whilst font-lock is turned on!) + ;; . Temporarily disable this, + ;; and consider what to do for other extra modes + ;; (isa-latex). +; (dolist (mode proof-xsym-extra-modes) +; (add-hook +; (intern (concat (symbol-name mode) "-hook")) +; 'proof-x-symbol-mode)) + ;; Font lock support is optional + + ;; FIXME: Isabelle wants this for sup/sub scripts + ;; presently loads too early and extends in modedef + ;; setups. Want to adjust here. + (if flks + (put symmode 'font-lock-defaults (list flks))) + ;; + ;; Finished. + (setq proof-x-symbol-initialized t)))))) + + +;;;###autoload +(defun proof-x-symbol-enable () + "Turn on or off support for x-symbol, initializing if necessary. +Calls proof-x-symbol-toggle-clean-buffers afterwards." + (if (and (proof-ass x-symbol-enable) (not proof-x-symbol-initialized)) + (progn + (set (proof-ass-sym x-symbol-enable) nil) ; assume failure! + (proof-x-symbol-initialize 'giveerrors) + (set (proof-ass-sym x-symbol-enable) t))) + (proof-x-symbol-mode-all-buffers) + (proof-x-symbol-toggle-clean-buffers)) + +(defun proof-x-symbol-toggle-clean-buffers () + "Clear the response buffer and send proof-showproof-command. +This function is intended to clean the display after a change +in the status of X-Symbol display. +This is a subroutine of proof-x-symbol-enable." + (proof-shell-maybe-erase-response nil t t) + (if (and proof-showproof-command (proof-shell-available-p)) + (proof-shell-invisible-command proof-showproof-command))) + +;;;###autoload +(defun proof-x-symbol-decode-region (start end) + "Call (x-symbol-decode-region START END), if x-symbol support is enabled. +This converts tokens in the region into X-Symbol characters. +Return new END value." + (if (proof-ass x-symbol-enable) + (save-excursion + (save-restriction + (narrow-to-region start end) + ;; FIXME: for GNU 21, this doesn't work always?? + ;; (OK for response, but not for goals, why?) + (x-symbol-decode-region start end) + ;; Decoding may change character positions. + ;; Return new end value + (point-max))) + end)) + +;; FIXME: see whether X-Symbol's supplied hook does the right +;; thing here. +(defun proof-x-symbol-encode-shell-input () + "Encode shell input in the variable STRING. +A value for proof-shell-insert-hook." + (and x-symbol-language + (setq string + (save-excursion + (let ((language x-symbol-language) + (coding x-symbol-coding) + (selective selective-display)) ;FIXME: needed? + (set-buffer (get-buffer-create "x-symbol comint")) + (erase-buffer) + (insert string) + (setq x-symbol-language language) + (setq x-symbol-8bits nil) + (setq x-symbol-coding nil) + (x-symbol-encode-all nil coding)) + (prog1 + (buffer-substring (point-min) (point-max)) + ;; FIXME da: maybe more efficient just to delete + ;; region. Make buffer name start with space + ;; to be unselectable. + (kill-buffer (current-buffer))))))) + + + + +(defun proof-x-symbol-mode-all-buffers () + "Activate/deactivate x-symbols in all Proof General buffers. +A subroutine of proof-x-symbol-enable." + ;; Response and goals buffer are fontified/decoded + ;; manually in the code, configuration only sets + ;; x-symbol-language. + (proof-map-buffers (list proof-goals-buffer + proof-response-buffer + proof-trace-buffer) + (proof-x-symbol-configure)) + ;; Shell has its own configuration + (proof-with-current-buffer-if-exists proof-shell-buffer + (proof-x-symbol-shell-config)) + ;; Script buffers are in X-Symbol's minor mode, + ;; And so are any other buffers kept in the same token language + (dolist (mode (cons proof-mode-for-script proof-xsym-extra-modes)) + (proof-map-buffers + (proof-buffers-in-mode mode) + (proof-x-symbol-mode)))) + +;; +;; Three functions for configuring buffers: +;; +;; proof-x-symbol-mode: for script buffer (X-Symbol minor mode) +;; proof-x-symbol-shell-config: for shell buffer (input hook) +;; proof-x-symbol-configure: for goals/response buffer (font lock) +;; + +(defun proof-x-symbol-set-language () + "Set x-symbol-language for the current proof assistant." + (setq x-symbol-language (proof-ass x-symbol-language))) + +;;;###autoload +(defun proof-x-symbol-mode () + "Turn on/off x-symbol mode in current buffer, from proof-x-symbol-enable. +The X-Symbol minor mode is only useful in buffers where symbol input +takes place (it isn't used for output-only buffers)." + (interactive) + (save-excursion ; needed or point moves: why? + (if proof-x-symbol-initialized + (progn + ;; Buffers which have XS minor mode toggled always keep + ;; x-symbol-language set. + (proof-x-symbol-set-language) + (x-symbol-mode (if (proof-ass x-symbol-enable) 1 0)) + ;; Font lock mode must be engaged for x-symbol to do its job + ;; properly, at least when there is no mule around. + (if (and x-symbol-mode (not (featurep 'mule))) + (if (not font-lock-mode) + (font-lock-mode) + ;; Even if font-lock was on before we may need to + ;; refontify now that the patterns (and buffer + ;; contents) have changed. Shouldn't x-symbol do this? + (font-lock-fontify-buffer))))))) + +;;;###autoload +(defun proof-x-symbol-shell-config () + "Configure the proof shell for x-symbol, if proof-x-symbol-support<>nil. +Assumes that the current buffer is the proof shell buffer." + ;; The best strategy seems to be *not* to turn on decoding + ;; in the shell itself. The reason is that there can be + ;; a clash between annotations and X-Symbol characters + ;; which leads to funny effects later. Moreover, the + ;; user isn't encouraged to interact directly with the + ;; shell, so we don't need to be helpful there. + ;; So we keep the shell buffer as plain text plus annotations. + ;; Even font-lock is problematical, so it should be switched off + ;; too. + (if proof-x-symbol-initialized + (progn + (cond + ((proof-ass x-symbol-enable) + (proof-x-symbol-set-language) + (if (and proof-xsym-activate-command + (proof-shell-live-buffer)) + (proof-shell-invisible-command + proof-xsym-activate-command 'wait)) + ;; We do encoding as the first step of input manipulation + (add-hook 'proof-shell-insert-hook + 'proof-x-symbol-encode-shell-input)) + ((not (proof-ass x-symbol-enable)) + (if (and proof-xsym-deactivate-command + (proof-shell-live-buffer)) + (proof-shell-invisible-command + proof-xsym-deactivate-command 'wait)) + (remove-hook 'proof-shell-insert-hook + 'proof-x-symbol-encode-shell-input) + ;; NB: x-symbol automatically adds an output filter but + ;; it doesn't actually get used unless the minor mode is + ;; active. Removing it here is just tidying up. + (remove-hook 'comint-output-filter-functions + 'x-symbol-comint-output-filter)))))) + +;;;###autoload +(defun proof-x-symbol-configure () + "Configure the current output buffer (goals/response/trace) for X-Symbol." + (if (proof-ass x-symbol-enable) + (progn + (proof-x-symbol-set-language) + ;; BEGIN: Code below from x-symbol.el/x-symbol-mode-internal + (unless (or (not (boundp 'enable-multibyte-characters)) + (not (fboundp 'set-buffer-multibyte)) + enable-multibyte-characters) + ;; Emacs: we need to convert the buffer from unibyte to multibyte + ;; since we'll use multibyte support for the symbol charset. + ;; TODO: try to do it less often + (let ((modified (buffer-modified-p)) + (inhibit-read-only t) + (inhibit-modification-hooks t)) + (unwind-protect + (progn + (decode-coding-region (point-min) (point-max) 'undecided) + (set-buffer-multibyte t)) + (set-buffer-modified-p modified)))) + ;; END code from x-symbol.el/x-symbol-mode-internal + + ;; If we're turning on x-symbol, attempt to convert to + ;; characters. (Only works if the buffer already + ;; contains tokens!) + (x-symbol-decode)))) + ;; Encoding back to tokens doesn't work too well: needs to + ;; do some de-fontification to remove font properties, and + ;; is flaky anyway because token -> char not nec injective. + ; (if (boundp 'x-symbol-language) + ; ;; If we're turning off x-symbol, convert back to tokens. + ; (x-symbol-encode)))) + + +;; +;; Try to initialize x-symbol-support on load-up if user has asked for it +;; +(if (proof-ass x-symbol-enable) + (progn + (proof-x-symbol-initialize) + (unless proof-x-symbol-initialized + ;; If init failed, turn off x-symbol-enable for the session. + (customize-set-variable (proof-ass-sym x-symbol-enable) nil)))) + +(provide 'proof-x-symbol) +;; End of proof-x-symbol.el diff --git a/generic/proof.el b/generic/proof.el new file mode 100644 index 00000000..6c93b7af --- /dev/null +++ b/generic/proof.el @@ -0,0 +1,123 @@ +;; proof.el Proof General loader. All files require this one. +;; +;; Copyright (C) 1998-2002 LFCS Edinburgh. +;; Authors: David Aspinall, Yves Bertot, Healfdene Goguen, +;; Thomas Kleymann and Dilip Sequeira +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; + +(require 'proof-site) ; site config +(require 'proof-compat) ; Emacs and OS compatibility +(require 'proof-utils) ; utilities +(require 'proof-config) ; configuration variables + + +(proof-splash-message) ; welcome the user now. + +;;; +;;; Extra autoloads that aren't automatic +;;; (defined with define-derived-mode) +;;; + +(autoload 'proof-mode "proof-script" + "Proof General major mode class for proof scripts.") + +(autoload 'proof-shell-mode "proof-shell" + "Proof General shell mode class for proof assistant processes") + + +;;; +;;; Global variables +;;; + +(deflocal proof-buffer-type nil + "Symbol for the type of this buffer: 'script, 'shell, 'goals, or 'response.") + +(defvar proof-shell-busy nil + "A lock indicating that the proof shell is processing. +When this is non-nil, proof-shell-ready-prover will give +an error.") + +(defvar proof-included-files-list nil + "List of files currently included in proof process. +This list contains files in canonical truename format +(see `file-truename'). + +Whenever a new file is being processed, it gets added to this list +via the proof-shell-process-file configuration settings. +When the prover retracts a file, this list is resynchronised via the +proof-shell-retract-files-regexp and proof-shell-compute-new-files-list +configuration settings. + +Only files which have been *fully* processed should be included here. +Proof General itself will automatically add the filenames of a script +buffer which has been completely read when scripting is deactivated. +It will automatically remove the filename of a script buffer which +is completely unread when scripting is deactivated. + +NB: Currently there is no generic provision for removing files which +are only partly read-in due to an error, so ideally the proof assistant +should only output a processed message when a file has been successfully +read.") + + +(defvar proof-script-buffer nil + "The currently active scripting buffer or nil if none.") + +;; FIXME: should fixup Coq's multiple file mode +(defvar proof-previous-script-buffer nil + "Previous value of proof-script-buffer, recorded when scripting turned off. +At the moment, this is only used for Coq's ugly multiple file code, +to help guess the directory of files Coq says it's reinterning.") + +(defvar proof-shell-buffer nil + "Process buffer where the proof assistant is run.") + +(defvar proof-goals-buffer nil + "The goals buffer.") + +(defvar proof-response-buffer nil + "The response buffer.") + +(defvar proof-trace-buffer nil + "A tracing buffer for storing tracing output from the proof shell. +See `proof-shell-trace-output-regexp' for details.") + +(defvar proof-thms-buffer nil + "A buffer for displaying a list of theorems from the proof assistant. +See `proof-shell-thm-display-regexp' for details.") + +(defvar proof-shell-error-or-interrupt-seen nil + "Flag indicating that an error or interrupt has just occurred. +Set to 'error or 'interrupt if one was observed from the proof +assistant during the last group of commands.") + +(defvar proof-shell-proof-completed nil + "Flag indicating that a completed proof has just been observed. +If non-nil, the value counts the commands from the last command +of the proof (starting from 1).") + +;; FIXME da: remove proof-terminal-string. At the moment some +;; commands need to have the terminal string, some don't. +;; It's used variously in proof-script and proof-shell, which +;; is another mess. [Shell mode implicitly assumes script mode +;; has been configured]. +;; We should assume commands are terminated at the specific level. + +(defvar proof-terminal-string nil + "End-of-line string for proof process.") + + + + +;;; +;;; Load other Proof General libraries +;;; + +(require 'proof-system) + + +(provide 'proof) +;; proof.el ends here diff --git a/generic/span-extent.el b/generic/span-extent.el new file mode 100644 index 00000000..adf85813 --- /dev/null +++ b/generic/span-extent.el @@ -0,0 +1,104 @@ +;; This file implements spans in terms of extents, for xemacs. +;; +;; Copyright (C) 1998 LFCS Edinburgh +;; Author: Healfdene Goguen +;; Maintainer: David Aspinall <da@dcs.ed.ac.uk> +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Bridging the emacs19/xemacs gulf ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; Now define "spans" in terms of extents. + +(defsubst make-span (start end) + "Make a span for the range [START, END) in current buffer." + (make-extent start end)) + +(defsubst detach-span (span) + "Remove SPAN from its buffer." + (detach-extent span)) + +(defsubst set-span-endpoints (span start end) + "Set the endpoints of SPAN to START, END." + (set-extent-endpoints span start end)) + +(defsubst set-span-property (span name value) + "Set SPAN's property NAME to VALUE." + (set-extent-property span name value)) + +(defsubst span-read-only (span) + "Set SPAN to be read only." + (set-span-property span 'read-only t)) + +(defsubst span-read-write (span) + "Set SPAN to be writeable." + (set-span-property span 'read-only nil)) + +(defun span-give-warning () + "Give a warning message." + (message "You should not edit here!")) + +(defun span-write-warning (span) + "Give a warning message when SPAN is changed." + ;; FIXME: implement this in XEmacs, perhaps with after-change-functions + (set-span-property span 'read-only nil)) + +(defsubst span-property (span name) + "Return SPAN's value for property PROPERTY." + (extent-property span name)) + +(defsubst delete-span (span) + "Delete SPAN." + (let ((predelfn (span-property span 'span-delete-action))) + (and predelfn (funcall predelfn))) + (delete-extent span)) + +(defsubst mapcar-spans (fn start end prop &optional val) + "Apply function FN to all spans between START and END with property PROP set" + (mapcar-extents fn nil (current-buffer) start end nil prop val)) + +(defsubst span-at (pt prop) + "Return the smallest SPAN at point PT with property PROP." + (extent-at pt nil prop)) + +(defsubst span-at-before (pt prop) + "Return the smallest SPAN at before PT with property PROP. +A span is before PT if it covers the character before PT." + (extent-at pt nil prop nil 'before)) + +(defsubst span-start (span) + "Return the start position of SPAN, or nil if SPAN is detatched." + (extent-start-position span)) + +(defsubst span-end (span) + "Return the end position of SPAN, or nil if SPAN is detatched." + (extent-end-position span)) + +(defsubst prev-span (span prop) + "Return span before SPAN with property PROP." + (extent-at (extent-start-position span) nil prop nil 'before)) + +(defsubst next-span (span prop) + "Return span after SPAN with property PROP." + (extent-at (extent-end-position span) nil prop nil 'after)) + +(defsubst span-live-p (span) + "Return non-nil if SPAN is live and in a live buffer." + (and span + (extent-live-p span) + (buffer-live-p (extent-object span)) + ;; PG 3.4: add third test here to see not detached. + (not (extent-detached-p span)))) + +(defun span-raise (span) + "Function added for FSF Emacs compatibility. Do nothing here." + nil) + +(defalias 'span-object 'extent-object) +(defalias 'span-string 'extent-string) + + +(provide 'span-extent) diff --git a/generic/span-overlay.el b/generic/span-overlay.el new file mode 100644 index 00000000..41097447 --- /dev/null +++ b/generic/span-overlay.el @@ -0,0 +1,317 @@ +;; This file implements spans in terms of extents, for emacs19. +;; +;; Copyright (C) 1998 LFCS Edinburgh +;; Author: Healfdene Goguen +;; Maintainer: David Aspinall <da@dcs.ed.ac.uk> +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Bridging the emacs19/xemacs gulf ;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; before-list represents a linked list of spans for each buffer. +;; It has the invariants of: +;; * being ordered wrt the starting point of the spans in the list, +;; with detached spans at the end. +;; * not having overlapping overlays of the same type. + +(defvar before-list nil + "Start of backwards-linked list of spans") + +(make-variable-buffer-local 'before-list) + + +(or (fboundp 'foldr) +(defun foldr (func a seq) + "Return (func (func (func (... (func a Sn) ...) S2) S1) S0) +when func's argument is 2 and seq is a sequence whose +elements = S0 S1 S2 ... Sn. [tl-seq.el]" + (let ((i (length seq))) + (while (> i 0) + (setq i (1- i)) + (setq a (funcall func a (elt seq i))) + ) + a))) + +(or (fboundp 'foldl) +(defun foldl (func a seq) + "Return (... (func (func (func a S0) S1) S2) ...) +when func's argument is 2 and seq is a sequence whose +elements = S0 S1 S2 .... [tl-seq.el]" + (let ((len (length seq)) + (i 0)) + (while (< i len) + (setq a (funcall func a (elt seq i))) + (setq i (1+ i)) + ) + a))) + +(defsubst span-start (span) + "Return the start position of SPAN." + (overlay-start span)) + +(defsubst span-end (span) + "Return the end position of SPAN." + (overlay-end span)) + +(defun set-span-property (span name value) + "Set SPAN's property NAME to VALUE." + (overlay-put span name value)) + +(defsubst span-property (span name) + "Return SPAN's value for property PROPERTY." + (overlay-get span name)) + +(defun span-read-only-hook (overlay after start end &optional len) + (unless inhibit-read-only + (error "Region is read-only"))) + +(defun span-read-only (span) + "Set SPAN to be read only." + ;; This function may be called on spans which are detached from a + ;; buffer, which gives an error here, since text-properties are + ;; associated with text in a particular buffer position. So we use + ;; our own read only hook. + ;(add-text-properties (span-start span) (span-end span) '(read-only t))) + ;; 30.8.02: tested using overlay-put as below with Emacs 21.2.1, + ;; bit this seems to have no effect when the overlay is added to + ;; the buffer. (Maybe read-only is only a text property, not an + ;; overlay property?). + ;; (overlay-put span 'read-only t)) + (set-span-property span 'modification-hooks '(span-read-only-hook)) + (set-span-property span 'insert-in-front-hooks '(span-read-only-hook))) + +(defun span-read-write (span) + "Set SPAN to be writeable." + ;; See comment above for text properties problem. + (set-span-property span 'modification-hooks nil) + (set-span-property span 'insert-in-front-hooks nil)) + +(defun span-give-warning (&rest args) + "Give a warning message." + (message "You should not edit here!")) + +(defun span-write-warning (span) + "Give a warning message when SPAN is changed." + (set-span-property span 'modification-hooks '(span-give-warning)) + (set-span-property span 'insert-in-front-hooks '(span-give-warning))) + +(defun int-nil-lt (m n) + (cond + ((eq m n) nil) + ((not n) t) + ((not m) nil) + (t (< m n)))) + +;; We use end first because proof-locked-queue is often changed, and +;; its starting point is always 1 +(defun span-lt (s u) + (or (int-nil-lt (span-end s) (span-end u)) + (and (eq (span-end s) (span-end u)) + (int-nil-lt (span-start s) (span-start u))))) + +(defun span-traverse (span prop) + (cond + ((not before-list) + ;; before-list empty + 'empty) + ((funcall prop before-list span) + ;; property holds for before-list and span + 'hd) + (t + ;; traverse before-list for property + (let ((l before-list) (before (span-property before-list 'before))) + (while (and before (not (funcall prop before span))) + (setq l before) + (setq before (span-property before 'before))) + l)))) + +(defun add-span (span) + (let ((ans (span-traverse span 'span-lt))) + (cond + ((eq ans 'empty) + (set-span-property span 'before nil) + (setq before-list span)) + ((eq ans 'hd) + (set-span-property span 'before before-list) + (setq before-list span)) + (t + (set-span-property span 'before + (span-property ans 'before)) + (set-span-property ans 'before span))))) + +(defun make-span (start end) + "Make a span for the range [START, END) in current buffer." + (add-span (make-overlay start end))) + +(defun remove-span (span) + (let ((ans (span-traverse span 'eq))) + (cond + ((eq ans 'empty) + (error "Bug: empty span list")) + ((eq ans 'hd) + (setq before-list (span-property before-list 'before))) + (ans + (set-span-property ans 'before (span-property span 'before))) + (t (error "Bug: span does not occur in span list"))))) + +;; extent-at gives "smallest" extent at pos +;; we're assuming right now that spans don't overlap +(defun spans-at-point (pt) + (let ((overlays nil) (os nil)) + (setq os (overlays-at pt)) + (while os + (if (not (memq (car os) overlays)) + (setq overlays (cons (car os) overlays))) + (setq os (cdr os))) + ;; NB: 6.4 (PG 3.4) da: added this next reverse + ;; since somewhere order is being confused; + ;; PBP is selecting _largest_ region rather than + ;; smallest!? + (if overlays (nreverse overlays)))) + +;; assumes that there are no repetitions in l or m +(defun append-unique (l m) + (foldl (lambda (n a) (if (memq a m) n (cons a n))) m l)) + +(defun spans-at-region (start end) + (let ((overlays nil) (pos start)) + (while (< pos end) + (setq overlays (append-unique (spans-at-point pos) overlays)) + (setq pos (next-overlay-change pos))) + overlays)) + +(defun spans-at-point-prop (pt prop) + (let ((f (cond + (prop (lambda (spans span) + (if (span-property span prop) (cons span spans) + spans))) + (t (lambda (spans span) (cons span spans)))))) + (foldl f nil (spans-at-point pt)))) + +(defun spans-at-region-prop (start end prop &optional val) + (let ((f (cond + (prop + (lambda (spans span) + (if (if val (eq (span-property span prop) val) + (span-property span prop)) + (cons span spans) + spans))) + (t + (lambda (spans span) (cons span spans)))))) + (foldl f nil (spans-at-region start end)))) + +(defun span-at (pt prop) + "Return the SPAN at point PT with property PROP. +For XEmacs, span-at gives smallest extent at pos. +For Emacs, we assume that spans don't overlap." + (car (spans-at-point-prop pt prop))) + +(defsubst detach-span (span) + "Remove SPAN from its buffer." + (remove-span span) + (delete-overlay span) + (add-span span)) + +(defsubst delete-span (span) + "Delete SPAN." + (let ((predelfn (span-property span 'span-delete-action))) + (and predelfn (funcall predelfn))) + (remove-span span) + (delete-overlay span)) + +;; The next two change ordering of list of spans: +(defsubst set-span-endpoints (span start end) + "Set the endpoints of SPAN to START, END. +Re-attaches SPAN if it was removed from the buffer." + (remove-span span) + (move-overlay span start end) + (add-span span)) + +(defsubst mapcar-spans (fn start end prop &optional val) + "Apply function FN to all spans between START and END with property PROP set" + (mapcar fn (spans-at-region-prop start end prop val))) + +(defun map-spans-aux (f l) + (cond (l (cons (funcall f l) (map-spans-aux f (span-property l 'before)))) + (t ()))) + +(defsubst map-spans (f) + (map-spans-aux f before-list)) + +(defun find-span-aux (prop-p l) + (while (and l (not (funcall prop-p l))) + (setq l (span-property l 'before))) + l) + +(defun find-span (prop-p) + (find-span-aux prop-p before-list)) + +(defun span-at-before (pt prop) + "Return the smallest SPAN at before PT with property PROP. +A span is before PT if it covers the character before PT." + (let ((prop-pt-p + (cond (prop (lambda (span) + (let ((start (span-start span))) + (and start (> pt start) + (span-property span prop))))) + (t (lambda (span) + (let ((start (span-start span))) + (and start (> pt start)))))))) + (find-span prop-pt-p))) + +(defun prev-span (span prop) + "Return span before SPAN with property PROP." + (let ((prev-prop-p + (cond (prop (lambda (span) (span-property span prop))) + (t (lambda (span) t))))) + (find-span-aux prev-prop-p (span-property span 'before)))) + +; overlays are [start, end) + +(defun next-span (span prop) + "Return span after SPAN with property PROP." + ;; 3.4 fix here: Now we do a proper search, so this should work with + ;; nested overlays, after a fashion. Use overlays-in to get a list + ;; for the entire buffer, this avoids repeatedly checking the same + ;; overlays in an ever expanding list (see v6.1). (However, this + ;; list may be huge: is it a bottleneck?) + ;; [Why has this function never used the before-list ?] + (let* ((start (overlay-start span)) + (pos start) + (nextos (overlays-in + (1+ start) + (point-max))) + (resstart (1+ (point-max))) + spanres newres) + ;; overlays are returned in an unspecified order; we + ;; must search whole list for a closest-next one. + (dolist (newres nextos spanres) + (if (and (span-property newres prop) + (< start (span-start newres)) + (< (span-start newres) resstart)) + (progn + (setq spanres newres) + (setq resstart (span-start spanres))))))) + +(defsubst span-live-p (span) + "Return non-nil if SPAN is in a live buffer." + (and span + (overlay-buffer span) + (buffer-live-p (overlay-buffer span)))) + +(defun span-raise (span) + "Set priority of span to make it appear above other spans. +FIXME: new hack added nov 99 because of disappearing overlays. +Behaviour is still worse than before." + (set-span-property span 'priority 100)) + +(defalias 'span-object 'overlay-buffer) + +(defun span-string (span) + (with-current-buffer (overlay-buffer span) + (buffer-substring (overlay-start span) (overlay-end span)))) + +(provide 'span-overlay) diff --git a/generic/span.el b/generic/span.el new file mode 100644 index 00000000..eb609f39 --- /dev/null +++ b/generic/span.el @@ -0,0 +1,39 @@ +;; span.el Datatype of "spans" for Proof General. +;; +;; Copyright (C) 1998 LFCS Edinburgh +;; Author: Healfdene Goguen +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ + +;; +;; Spans are our abstraction of extents/overlays. +;; +(eval-and-compile + (cond ((string-match "XEmacs" emacs-version) + (require 'span-extent)) + (t + (require 'span-overlay)))) + +;; +;; Generic functions built on low-level concrete ones. +;; + +(defsubst delete-spans (start end prop) + "Delete all spans between START and END with property PROP set." + (mapcar-spans 'delete-span start end prop)) + +(defsubst span-property-safe (span name) + "Like span-property, but return nil if SPAN is nil." + (and span (span-property span name))) + +(defsubst set-span-start (span value) + "Set the start point of SPAN to VALUE." + (set-span-endpoints span value (span-end span))) + +(defsubst set-span-end (span value) + "Set the end point of SPAN to VALUE." + (set-span-endpoints span (span-start span) value)) + +(provide 'span) +;; span.el ends here. diff --git a/generic/texi-docstring-magic.el b/generic/texi-docstring-magic.el new file mode 100644 index 00000000..06bb5ad8 --- /dev/null +++ b/generic/texi-docstring-magic.el @@ -0,0 +1,383 @@ +;; texi-docstring-magic.el -- munge internal docstrings into texi +;; +;; Keywords: lisp, docs, tex +;; Author: David Aspinall <da@dcs.ed.ac.uk> +;; Copyright (C) 1998 David Aspinall +;; License: GPL (GNU GENERAL PUBLIC LICENSE) +;; +;; $Id$ +;; +;; This file is distributed under the terms of the GNU General Public +;; License, Version 2. Find a copy of the GPL with your version of +;; GNU Emacs or Texinfo. +;; +;; +;; This package generates Texinfo source fragments from Emacs +;; docstrings. This avoids documenting functions and variables +;; in more than one place, and automatically adds Texinfo markup +;; to docstrings. +;; +;; It relies heavily on you following the Elisp documentation +;; conventions to produce sensible output, check the Elisp manual +;; for details. In brief: +;; +;; * The first line of a docstring should be a complete sentence. +;; * Arguments to functions should be written in upper case: ARG1..ARGN +;; * User options (variables users may want to set) should have docstrings +;; beginning with an asterisk. +;; +;; Usage: +;; +;; Write comments of the form: +;; +;; @c TEXI DOCSTRING MAGIC: my-package-function-or-variable-name +;; +;; In your texi source, mypackage.texi. From within an Emacs session +;; where my-package is loaded, visit mypackage.texi and run +;; M-x texi-docstring-magic to update all of the documentation strings. +;; +;; This will insert @defopt, @deffn and the like underneath the +;; magic comment strings. +;; +;; The default value for user options will be printed. +;; +;; Symbols are recognized if they are defined for faces, functions, +;; or variables (in that order). +;; +;; Automatic markup rules: +;; +;; 1. Indented lines are gathered into a @lisp environment. +;; 2. Pieces of text `stuff' or surrounded in quotes marked up with @samp. +;; 3. Words *emphasized* are made @strong{emphasized} +;; 4. Words sym-bol which are symbols become @code{sym-bol}. +;; 5. Upper cased words ARG corresponding to arguments become @var{arg}. +;; In fact, you can any word longer than three letters, so that +;; metavariables can be used easily. +;; FIXME: to escape this, use `ARG' +;; 6. Words 'sym which are lisp-quoted are marked with @code{'sym}. +;; +;; ----- +;; +;; Useful key binding when writing Texinfo: +;; +;; (define-key TeXinfo-mode-map "C-cC-d" 'texi-docstring-magic-insert-magic) +;; +;; ----- +;; +;; Useful enhancements to do: +;; +;; * Tweak replacement: at the moment it skips blank lines +;; under magic comment. +;; * Use customize properties (e.g. group, simple types) +;; * Look for a "texi-docstring" property for symbols +;; so TeXInfo can be defined directly in case automatic markup +;; goes badly wrong. +;; * Add tags to special comments so that user can specify face, +;; function, or variable binding for a symbol in case more than +;; one binding exists. +;; +;; ------ + +(defun texi-docstring-magic-find-face (face) + ;; Compatibility between FSF Emacs and XEmacs + (or (facep face) + (and (fboundp 'find-face) (find-face face)))) + +(defun texi-docstring-magic-splice-sep (strings sep) + "Return concatenation of STRINGS spliced together with separator SEP." + (let (str) + (while strings + (setq str (concat str (car strings))) + (if (cdr strings) + (setq str (concat str sep))) + (setq strings (cdr strings))) + str)) + +(defconst texi-docstring-magic-munge-table + '(;; 0. FIXME: escape @, { and } characters + ;; ("@" t "@@") + ;;("{" t "\\{") + ;; ("}" t "\\}") + ;; 1. Indented lines are gathered into @lisp environment. + ("\\(^.*\\S-.*$\\)" + t + (let + ((line (match-string 0 docstring))) + (if (eq (char-syntax (string-to-char line)) ?\ ) + ;; whitespace + (if in-quoted-region + line + (setq in-quoted-region t) + (concat "@lisp\n" line)) + ;; non-white space + (if in-quoted-region + (progn + (setq in-quoted-region nil) + (concat "@end lisp\n" line)) + line)))) + ;; 2. Pieces of text `stuff' or surrounded in quotes + ;; are marked up with @samp. NB: Must be backquote + ;; followed by forward quote for this to work. + ;; Can't use two forward quotes else problems with + ;; symbols. + ;; Odd hack: because ' is a word constituent in text/texinfo + ;; mode, putting this first enables the recognition of args + ;; and symbols put inside quotes. + ("\\(`\\([^']+\\)'\\)" + t + (concat "@samp{" (match-string 2 docstring) "}")) + ;; 3. Words *emphasized* are made @strong{emphasized} + ("\\(\\*\\(\\w+\\)\\*\\)" + t + (concat "@strong{" (match-string 2 docstring) "}")) + ;; 4. Words sym-bol which are symbols become @code{sym-bol}. + ;; Must have at least one hyphen to be recognized, + ;; terminated in whitespace, end of line, or punctuation. + ;; Only consider symbols made from word constituents + ;; and hyphen. + ("\\(\\(\\w+\\-\\(\\w\\|\\-\\)+\\)\\)\\(\\s\)\\|\\s-\\|\\s.\\|$\\)" + (or (boundp (intern (match-string 2 docstring))) + (fboundp (intern (match-string 2 docstring)))) + (concat "@code{" (match-string 2 docstring) "}" + (match-string 4 docstring))) + ;; 5. Upper cased words ARG corresponding to arguments become + ;; @var{arg} + ;; In fact, include any word so long as it is more than 3 characters + ;; long. (Comes after symbols to avoid recognizing the + ;; lowercased form of an argument as a symbol) + ;; FIXME: maybe we don't want to downcase stuff already + ;; inside @samp + ;; FIXME: should - terminate? should _ be included? + ("\\([A-Z0-9_\\-]+\\)\\(/\\|\)\\|}\\|\\s-\\|\\s.\\|$\\)" + (or (> (length (match-string 1 docstring)) 3) + (member (downcase (match-string 1 docstring)) args)) + (concat "@var{" (downcase (match-string 1 docstring)) "}" + (match-string 2 docstring))) + + ;; 6. Words 'sym which are lisp quoted are + ;; marked with @code. + ("\\(\\(\\s-\\|^\\)'\\(\\(\\w\\|\\-\\)+\\)\\)\\(\\s\)\\|\\s-\\|\\s.\\|$\\)" + t + (concat (match-string 2 docstring) + "@code{'" (match-string 3 docstring) "}" + (match-string 5 docstring))) + ;; 7,8. Clean up for @lisp environments left with spurious newlines + ;; after 1. + ("\\(\\(^\\s-*$\\)\n@lisp\\)" t "@lisp") + ("\\(\\(^\\s-*$\\)\n@end lisp\\)" t "@end lisp") + ;; 9. Hack to remove @samp{@var{...}} sequences. + ;; Changed to just @samp of uppercase. + ("\\(@samp{@var{\\([^}]+\\)}}\\)" + t + (concat "@samp{" (upcase (match-string 2 docstring)) "}"))) + "Table of regexp matches and replacements used to markup docstrings. +Format of table is a list of elements of the form + (regexp predicate replacement-form) +If regexp matches and predicate holds, then replacement-form is +evaluated to get the replacement for the match. +predicate and replacement-form can use variables arg, +and forms such as (match-string 1 docstring) +Match string 1 is assumed to determine the +length of the matched item, hence where parsing restarts from. +The replacement must cover the whole match (match string 0), +including any whitespace included to delimit matches.") + + +(defun texi-docstring-magic-untabify (string) + "Convert tabs in STRING into multiple spaces." + (save-excursion + (set-buffer + (get-buffer-create " texi-docstring-magic-untabify")) + (insert string) + (untabify (point-min) (point-max)) + (prog1 (buffer-substring) + (kill-buffer (current-buffer))))) + +(defun texi-docstring-magic-munge-docstring (docstring args) + "Markup DOCSTRING for texi according to regexp matches." + (let ((case-fold-search nil)) + (setq docstring (texi-docstring-magic-untabify docstring)) + (dolist (test texi-docstring-magic-munge-table) + (let ((regexp (nth 0 test)) + (predicate (nth 1 test)) + (replace (nth 2 test)) + (i 0) + in-quoted-region) + + (while (and + (< i (length docstring)) + (string-match regexp docstring i)) + (setq i (match-end 1)) + (if (eval predicate) + (let* ((origlength (- (match-end 0) (match-beginning 0))) + (replacement (eval replace)) + (newlength (length replacement))) + (setq docstring + (replace-match replacement t t docstring)) + (setq i (+ i (- newlength origlength)))))) + (if in-quoted-region + (setq docstring (concat docstring "\n@end lisp")))))) + ;; Force a new line after (what should be) the first sentence, + ;; if not already a new paragraph. + (let* + ((pos (string-match "\n" docstring)) + (needscr (and pos + (not (string= "\n" + (substring docstring + (1+ pos) + (+ pos 2))))))) + (if (and pos needscr) + (concat (substring docstring 0 pos) + "@*\n" + (substring docstring (1+ pos))) + docstring))) + +(defun texi-docstring-magic-texi (env grp name docstring args &optional endtext) + "Make a texi def environment ENV for entity NAME with DOCSTRING." + (concat "@def" env (if grp (concat " " grp) "") " " name + " " + (texi-docstring-magic-splice-sep args " ") + ;; " " + ;; (texi-docstring-magic-splice-sep extras " ") + "\n" + (texi-docstring-magic-munge-docstring docstring args) + "\n" + (or endtext "") + "@end def" env "\n")) + +(defun texi-docstring-magic-format-default (default) + "Make a default value string for the value DEFAULT. +Markup as @code{stuff} or @lisp stuff @end lisp." + ;; NB: might be nice to use a 'default-value-description + ;; property here, in case the default value is computed. + (let ((text (format "%S" default))) + (concat + "\nThe default value is " + (if (string-match "\n" text) + ;; Carriage return will break @code, use @lisp + (if (stringp default) + (concat "the string: \n@lisp\n" default "\n@end lisp\n") + (concat "the value: \n@lisp\n" text "\n@end lisp\n")) + (concat "@code{" text "}.\n"))))) + + +(defun texi-docstring-magic-texi-for (symbol) + (cond + ;; Faces + ((texi-docstring-magic-find-face symbol) + (let* + ((face symbol) + (name (symbol-name face)) + (docstring (or (face-doc-string face) + "Not documented.")) + (useropt (eq ?* (string-to-char docstring)))) + ;; Chop off user option setting + (if useropt + (setq docstring (substring docstring 1))) + (texi-docstring-magic-texi "fn" "Face" name docstring nil))) + ((boundp symbol) + ;; Variables. + (let* + ((variable symbol) + (name (symbol-name variable)) + (docstring (or (documentation-property variable + 'variable-documentation) + "Not documented.")) + (useropt (eq ?* (string-to-char docstring))) + (default (if useropt + (texi-docstring-magic-format-default + (default-value symbol))))) + ;; Chop off user option setting + (if useropt + (setq docstring (substring docstring 1))) + (texi-docstring-magic-texi + (if useropt "opt" "var") nil name docstring nil default))) + ((fboundp symbol) + ;; Functions. Functions with same name as variables are documented + ;; as variables. + ;; We don't handle macros, aliases, or compiled fns properly. + (let* + ((function symbol) + (name (symbol-name function)) + (docstring (or (documentation function) + "Not documented.")) + (def (symbol-function function)) + (macrop (eq 'macro (car-safe def))) + (argsyms (cond ((eq (car-safe def) 'lambda) + (nth 1 def)))) + (args (mapcar 'symbol-name argsyms))) + (cond + ((commandp function) + (texi-docstring-magic-texi "fn" "Command" name docstring args)) + (macrop + (texi-docstring-magic-texi "fn" "Macro" name docstring args)) + (t + (texi-docstring-magic-texi "un" nil name docstring args))))) + (t + (error "Don't know anything about symbol %s" (symbol-name symbol))))) + +(defconst texi-docstring-magic-comment + "@c TEXI DOCSTRING MAGIC:" + "Magic string in a texi buffer expanded into @defopt, or @deffn.") + + +;;;###autoload +(defun texi-docstring-magic () + "Update all texi docstring magic annotations in buffer." + (interactive) + (save-excursion + (goto-char (point-min)) + (let ((magic (concat "^" + (regexp-quote texi-docstring-magic-comment) + "\\s-*\\(\\(\\w\\|\\-\\)+\\)\\s-*$")) + p + symbol) + (while (re-search-forward magic nil t) + (setq symbol (intern (match-string 1))) + (forward-line) + (setq p (point)) + ;; If comment already followed by an environment, delete it. + (if (and + (looking-at "@def\\(\\w+\\)\\s-") + (search-forward (concat "@end def" (match-string 1)) nil t)) + (progn + (forward-line) + (delete-region p (point)))) + (insert + (texi-docstring-magic-texi-for symbol)))))) + +(defun texi-docstring-magic-face-at-point () + (ignore-errors + (let ((stab (syntax-table))) + (unwind-protect + (save-excursion + (set-syntax-table emacs-lisp-mode-syntax-table) + (or (not (zerop (skip-syntax-backward "_w"))) + (eq (char-syntax (char-after (point))) ?w) + (eq (char-syntax (char-after (point))) ?_) + (forward-sexp -1)) + (skip-chars-forward "'") + (let ((obj (read (current-buffer)))) + (and (symbolp obj) (texi-docstring-magic-find-face obj) obj))) + (set-syntax-table stab))))) + +(defun texi-docstring-magic-insert-magic (symbol) + (interactive + (let* ((v (or (variable-at-point) + (function-at-point) + (texi-docstring-magic-face-at-point))) + (val (let ((enable-recursive-minibuffers t)) + (completing-read + (if v + (format "Magic docstring for symbol (default %s): " v) + "Magic docstring for symbol: ") + obarray '(lambda (sym) + (or (boundp sym) + (fboundp sym) + (texi-docstring-magic-find-face sym))) + t nil 'variable-history)))) + (list (if (equal val "") v (intern val))))) + (insert "\n" texi-docstring-magic-comment " " (symbol-name symbol))) + + +(provide 'texi-docstring-magic) |