├── modes ├── darcsum │ ├── TODO │ ├── perfect-darcs-mode.txt │ └── darcsum.el ├── agda2 │ ├── agda2.el │ ├── agda2-abbrevs.el │ ├── eri.el │ ├── annotation.el │ ├── agda2-highlight.el │ ├── agda-input.el │ └── agda2-mode.el └── init.el ├── .gitignore ├── color-themes ├── init.el └── color-theme-vivid-chalk.el ├── .gitmodules ├── Preferences.el ├── customizations.el └── json.el /modes/darcsum/TODO: -------------------------------------------------------------------------------- 1 | * Handle whatsnew in subdirectories 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Nested repository source-code-control information 2 | _darcs/ 3 | 4 | # Transitory AquaMacs stuff 5 | .id 6 | Recent Files.el 7 | frame-positions.el 8 | minibuffer-history.el 9 | places.el 10 | auto-save-list/ -------------------------------------------------------------------------------- /color-themes/init.el: -------------------------------------------------------------------------------- 1 | (require 'color-theme) 2 | (color-theme-initialize) 3 | 4 | (add-subdirectories-of-to-load-path "~/Library/Preferences/Aquamacs Emacs/color-themes") 5 | (load "color-theme-twilight") 6 | (load "color-theme-vivid-chalk") 7 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "color-themes/twilight"] 2 | path = color-themes/twilight 3 | url = git://github.com/crafterm/twilight-emacs.git 4 | [submodule "modes/gitsum"] 5 | path = modes/gitsum 6 | url = git://github.com/chneukirchen/gitsum.git 7 | [submodule "modes/textmate"] 8 | path = modes/textmate 9 | url = git://github.com/defunkt/textmate.el.git 10 | -------------------------------------------------------------------------------- /modes/agda2/agda2.el: -------------------------------------------------------------------------------- 1 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 2 | ;; Agda mode code which should run before the first Agda file is 3 | ;; loaded 4 | 5 | (autoload 'agda2-mode "agda2-mode" 6 | "Major mode for editing Agda files (version ≥ 2)." t) 7 | (add-to-list 'auto-mode-alist '("\\.l?agda\\'" . agda2-mode)) 8 | (modify-coding-system-alist 'file "\\.l?agda\\'" 'utf-8) 9 | 10 | (provide 'agda2) 11 | -------------------------------------------------------------------------------- /modes/init.el: -------------------------------------------------------------------------------- 1 | ;; ======== 2 | ;; Textmate Mode Missing Library Functions 3 | ;; ======== 4 | (defun string-join (separator strings) 5 | (mapconcat 'identity strings separator)) 6 | 7 | ;; ======== 8 | ;; Load Modes 9 | ;; ======== 10 | (add-subdirectories-of-to-load-path "~/Library/Preferences/Aquamacs Emacs/modes") 11 | (require 'gitsum) 12 | (require 'darcsum) 13 | (require 'haskell-mode) 14 | (require 'textmate) 15 | (load-file (let ((coding-system-for-read 'utf-8)) 16 | (shell-command-to-string "agda-mode locate"))) 17 | 18 | ;; ======== 19 | ;; Haskell Mode Configuration 20 | ;; ======== 21 | (add-hook 'haskell-mode-hook 'turn-on-haskell-doc-mode) 22 | (add-hook 'haskell-mode-hook 'turn-on-haskell-indent) 23 | ;;(add-hook 'haskell-mode-hook 'turn-on-haskell-simple-indent) ;; Indentation modes are mutually exclusive 24 | (add-hook 'haskell-mode-hook 'font-lock-mode) 25 | 26 | 27 | -------------------------------------------------------------------------------- /color-themes/color-theme-vivid-chalk.el: -------------------------------------------------------------------------------- 1 | ;; Vivid Chalk Theme for Emacs. 2 | ;; 3 | ;; Taken from thread at http://groups.google.com/group/emacs-on-rails/browse_thread/thread/f99e3707e59eff6d/3e2c29751d9909b7?lnk=raot by "Mark" 4 | 5 | (defun color-theme-vivid-chalk () 6 | "Based on Vivid Chalk, a vim port of Vibrant Ink." 7 | (interactive) 8 | (color-theme-install 9 | '(color-theme-vivid-chalk 10 | ((background-color . "black") 11 | (background-mode . dark) 12 | (border-color . "black") 13 | (cursor-color . "white") 14 | (foreground-color . "white") 15 | (list-matching-lines-face . bold) 16 | (view-highlight-face . highlight)) 17 | (default ((t (nil)))) 18 | (bold ((t (:bold t)))) 19 | (bold-italic ((t (:italic t :bold t)))) 20 | (fringe ((t (:background "black")))) 21 | (font-lock-builtin-face ((t (:foreground "#aaccff")))) 22 | (font-lock-comment-face ((t (:italic t :foreground "#9933cc")))) 23 | (font-lock-comment-delimiter-face ((t (:foreground "#9933cc")))) 24 | (font-lock-constant-face ((t (:foreground "#339999")))) 25 | (font-lock-function-name-face ((t (:foreground "#ffcc00")))) 26 | (font-lock-keyword-face ((t (:foreground "#ff6600")))) 27 | (font-lock-preprocessor-face ((t (:foreground "#aaffff")))) 28 | (font-lock-reference-face ((t (:foreground "LightSteelBlue")))) 29 | (font-lock-string-face ((t (:foreground "#66FF00")))) 30 | (font-lock-doc-face ((t (:foreground "LightSalmon")))) 31 | (font-lock-type-face ((t (:italic t :foreground "#aaaaaa")))) 32 | (font-lock-variable-name-face ((t (:foreground "#aaccff")))) 33 | (font-lock-warning-face ((t (:bold t :foreground "Pink")))) 34 | (paren-face-match-light ((t (:background "#222222")))) 35 | (highlight ((t (:background "darkolivegreen")))) 36 | (italic ((t (:italic t)))) 37 | (modeline ((t (:background "#a5baf1" :foreground "black")))) 38 | (modeline-buffer-id ((t (:background "#a5baf1" :foreground 39 | "black")))) 40 | (modeline-mousable ((t (:background "#a5baf1" :foreground 41 | "black")))) 42 | (modeline-mousable-minor-mode ((t (:background 43 | "#a5baf1" :foreground "black")))) 44 | (region ((t (:background "#555577")))) 45 | (primary-selection ((t (:background "#555577")))) 46 | (isearch ((t (:background "#555555")))) 47 | (zmacs-region ((t (:background "#555577")))) 48 | (secondary-selection ((t (:background "darkslateblue")))) 49 | (flymake-errline ((t (:background "LightSalmon" :foreground 50 | "black")))) 51 | (flymake-warnline ((t (:background "LightSteelBlue" :foreground 52 | "black")))) 53 | (underline ((t (:underline t)))) 54 | (minibuffer-prompt ((t (:bold t :foreground "#ff6600"))))))) -------------------------------------------------------------------------------- /modes/darcsum/perfect-darcs-mode.txt: -------------------------------------------------------------------------------- 1 | (I wrote this in late 2004 on request of forcer, being unsatisfied 2 | with the state of Emacs modes for darcs at that time. My additions of 3 | March 2005 are added in parentheses.) 4 | 5 | The "perfect" darcs-mode 6 | ======================== 7 | 8 | This is a short specification of features I'd like to have in a future 9 | Emacs darcs-mode. 10 | 11 | 12 | The Edit/Update-Log cycle 13 | ------------------------- 14 | 15 | darcs-mode should encourage the Arch style of writing the log message 16 | as you go along. This is known as the Edit/Update-Log cycle and 17 | works like this (Xtla keybindings are shown): 18 | 19 | - Edit (file status in modeline, unchanged/edited) 20 | - Add change entry (C-x T a) 21 | ChangeLog style, * [filename]: ([function]) ... 22 | This will use the `add-to-changelog "intelligence"' that combines 23 | changes of the same file etc. 24 | The buffer will be passed to darcs record using --logfile. 25 | - Repeat 26 | 27 | You will do this all day, so it should be *very* convenient and 28 | streamlined to do. (Note that the Update-Log step is not enforced; 29 | people that don't like it can simply write the message just before 30 | recording.) 31 | 32 | When you are finished with editing you'll do this: 33 | 34 | - Review changes (C-x T =, darcs diff) 35 | - Clean up patch (RET to jump in diff) 36 | - Possibly mark only certain patches to record (m in diff, darcsum 37 | style) 38 | - Check record message (c in diff) 39 | - Commit (C-c C-c in log buffer) 40 | 41 | Now you can go along making the next patch. 42 | 43 | 44 | Exploring history 45 | ----------------- 46 | 47 | darcs-mode should provide a good patch browser in style of Xtla's 48 | tla-revision or darcs.cgi's patch view. 49 | 50 | You'll see a list of patches (darcs changes); one line per patch. By 51 | tapping RET on a patch, it's summary will appear (full record message, 52 | changed file statistics). Pressing d or = will show the patch as a 53 | diff in a separate buffer. 54 | 55 | The use of color and providing good search features will make this 56 | mode especially useful. (Search by date, by changed files, by record 57 | message etc... Highlight tags, show tags only, group patches by 58 | author, by date ("What did we do this week?")) 59 | 60 | The patch browser will also be used to mark and send patches. 61 | 62 | Being able to select multiple patches and look at their unification 63 | would be very useful too (tla delta, darcs diff --from... --to...). 64 | 65 | 66 | Exploring the inventory 67 | ----------------------- 68 | 69 | A file browser like darcs.cgi's file view or tla-inventory is needed 70 | to see which files have changed. It should be possible to see a patch 71 | list (in the patch browser) for each file (darcs changes file...). 72 | 73 | Annotation of files (with hyperlinks to the patches) like vc-annotate 74 | would be very nice to have too. 75 | 76 | 77 | Other features 78 | -------------- 79 | 80 | Provide tight coupling with other Emacs parts, not limited to Gnus and 81 | BBDB. Emacs lives from its integration. 82 | -------------------------------------------------------------------------------- /modes/agda2/agda2-abbrevs.el: -------------------------------------------------------------------------------- 1 | ;; agda2-abbrevs.el --- Default Agda abbrevs 2 | 3 | ;;; Commentary: 4 | 5 | ;;; Code: 6 | 7 | ;; Skeletons 8 | 9 | (require 'skeleton) 10 | 11 | (define-skeleton agda2-abbrevs-module 12 | "Inserts a module header template." 13 | nil 14 | "module " _ " where\n") 15 | 16 | (define-skeleton agda2-abbrevs-data 17 | "Inserts a data template." 18 | nil 19 | "data " _ " : Set where\n") 20 | 21 | (define-skeleton agda2-abbrevs-codata 22 | "Inserts a codata template." 23 | nil 24 | "codata " _ " : Set where\n") 25 | 26 | (define-skeleton agda2-abbrevs-record 27 | "Inserts a record type template." 28 | nil 29 | "record " _ " : Set where\n" 30 | " field\n") 31 | 32 | (define-skeleton agda2-abbrevs-record-value 33 | "Inserts a record value template." 34 | nil 35 | "record {" _ "}") 36 | 37 | (define-skeleton agda2-abbrevs-using 38 | "Inserts a using template." 39 | nil 40 | "using (" _ ")") 41 | 42 | (define-skeleton agda2-abbrevs-hiding 43 | "Inserts a hiding template." 44 | nil 45 | "hiding (" _ ")") 46 | 47 | (define-skeleton agda2-abbrevs-renaming 48 | "Inserts a renaming template." 49 | nil 50 | "renaming (" _ " to " _ ")") 51 | 52 | (define-skeleton agda2-abbrevs-forall 53 | "Inserts a forall template." 54 | nil 55 | "∀ {" _ "} ") 56 | 57 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 58 | ;; Abbrevs 59 | 60 | (defvar agda2-abbrevs-defaults '( 61 | ("m" "" agda2-abbrevs-module) 62 | ("d" "" agda2-abbrevs-data) 63 | ("c" "" agda2-abbrevs-codata) 64 | ("re" "" agda2-abbrevs-record) 65 | ("rv" "" agda2-abbrevs-record-value) 66 | ("u" "" agda2-abbrevs-using) 67 | ("h" "" agda2-abbrevs-hiding) 68 | ("r" "" agda2-abbrevs-renaming) 69 | ("w" "where\n") 70 | ("po" "postulate") 71 | ("a" "abstract\n") 72 | ("pr" "private\n") 73 | ("pu" "public") 74 | ("mu" "mutual\n") 75 | ("f" "" agda2-abbrevs-forall) 76 | ("oi" "open import ")) 77 | "Abbreviations defined by default in the Agda mode.") 78 | 79 | (defcustom agda2-mode-abbrevs-use-defaults t 80 | "If non-nil include the default Agda mode abbrevs in `agda2-mode-abbrev-table'. 81 | The abbrevs are designed to be expanded explicitly, so users of `abbrev-mode' 82 | probably do not want to include them. 83 | 84 | Restart Emacs in order for this change to take effect." 85 | :group 'agda2 86 | :type '(choice (const :tag "Yes" t) 87 | (const :tag "No" nil))) 88 | 89 | (defvar agda2-mode-abbrev-table nil 90 | "Agda mode abbrev table.") 91 | 92 | (define-abbrev-table 93 | 'agda2-mode-abbrev-table 94 | (if agda2-mode-abbrevs-use-defaults 95 | (mapcar (lambda (abbrev) 96 | (append abbrev 97 | (make-list (- 4 (length abbrev)) nil) 98 | '((:system t)))) 99 | agda2-abbrevs-defaults))) 100 | 101 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 102 | ;; Administrative details 103 | 104 | (provide 'agda2-abbrevs) 105 | ;;; agda2-abbrevs.el ends here 106 | -------------------------------------------------------------------------------- /Preferences.el: -------------------------------------------------------------------------------- 1 | ;; This is the Aquamacs Preferences file. 2 | ;; Add Emacs-Lisp code here that should be executed whenever 3 | ;; you start Aquamacs Emacs. If errors occur, Aquamacs will stop 4 | ;; evaluating this file and print errors in the *Messags* buffer. 5 | ;; Use this file in place of ~/.emacs (which is loaded as well.) 6 | 7 | ;; ======== 8 | ;; Utility Functions 9 | ;; ======== 10 | 11 | (defun add-subdirectories-of-to-load-path (my-lisp-dir) 12 | "Add the subdirectories of the given path to the load path" 13 | (if (fboundp 'normal-top-level-add-subdirs-to-load-path) 14 | (let* ((default-directory my-lisp-dir)) 15 | (setq load-path (cons my-lisp-dir load-path)) 16 | (normal-top-level-add-subdirs-to-load-path)))) 17 | 18 | ;; ======== 19 | ;; Load modes and color-themes seperately since they are likely to proliferate 20 | ;; ======== 21 | (load-file "~/Library/Preferences/Aquamacs Emacs/modes/init.el") 22 | (load-file "~/Library/Preferences/Aquamacs Emacs/color-themes/init.el") 23 | 24 | ;; ======== 25 | ;; Global settings 26 | ;; ======== 27 | (setq fill-column 110) ;; The default of 72 is too narrow 28 | (setq indent-tabs-mode nil) ;; Tabs are evil, always use spaces instead 29 | (ido-mode t) ;; Buffer switching like TextMate Apple-T 30 | 31 | ;; ======== 32 | ;; Global Keybindings 33 | ;; ======== 34 | (global-set-key [(control up)] '(lambda () (interactive) (previous-line 4))) 35 | (global-set-key [(control down)] '(lambda () (interactive) (next-line 4))) 36 | 37 | ;; ======== 38 | ;; Global Hooks 39 | ;; ======== 40 | 41 | ;; Darcs Hooks: 42 | ;; http://wiki.darcs.net/DarcsWiki/CategoryEmacs 43 | 44 | ; prevent accidental editing of files in darcs repository 45 | (add-hook 'find-file-hooks 'label-darcs-file-with-warning) 46 | ; warn against accidental writing to a _darcs file 47 | (add-hook 'write-file-hooks 'warn-writing-darcs-file) 48 | ; affix a warning label to any _darcs file buffer 49 | (defun label-darcs-file-with-warning() 50 | (let ((f (buffer-file-name (current-buffer)))) 51 | (and f (string-match "_darcs" f) 52 | (rename-buffer (concat "_DARCS-FILE:" (buffer-name)) t)))) 53 | ; prevent accidental writing of files in darcs repository 54 | (defun warn-writing-darcs-file() 55 | (let ((f (buffer-file-name (current-buffer)))) 56 | (and f (string-match "_darcs" f) 57 | (if (not (y-or-n-p "WARNING: YOU ARE ABOUT TO WRITE TO an _darcs file, are you sure you want to do this? ")) 58 | (keyboard-quit))))) 59 | 60 | ;; Scion Hooks 61 | 62 | ;; Substitute the desired version for 63 | (add-to-list 'load-path "~/.cabal/share/scion-0.1.0.2/emacs") 64 | (require 'scion) 65 | 66 | ;; if ./cabal/bin is not in your $PATH 67 | (setq scion-program "~/.cabal/bin/scion-server") 68 | 69 | (defun my-haskell-hook () 70 | (define-key scion-mode-map [f5] 'scion-load) 71 | ;; Whenever we open a file in Haskell mode, also activate Scion 72 | (scion-mode 1) 73 | ;; Whenever a file is saved, immediately type check it and 74 | ;; highlight errors/warnings in the source. 75 | (scion-flycheck-on-save 1)) 76 | 77 | (add-hook 'haskell-mode-hook 'my-haskell-hook) 78 | 79 | ;; Use ido-mode completion (matches anywhere, not just beginning) 80 | ;; 81 | ;; WARNING: This causes some versions of Emacs to fail so badly 82 | ;; that Emacs needs to be restarted. 83 | (setq scion-completing-read-function 'ido-completing-read) 84 | -------------------------------------------------------------------------------- /modes/agda2/eri.el: -------------------------------------------------------------------------------- 1 | ;;; eri.el --- Enhanced relative indentation (eri) 2 | 3 | ;;; Commentary: 4 | 5 | ;;; Code: 6 | 7 | (require 'cl) 8 | 9 | (defun eri-current-line-length nil 10 | "Calculates length of current line." 11 | (- (line-end-position) (line-beginning-position))) 12 | 13 | (defun eri-current-line-empty nil 14 | "Return non-nil if the current line is empty (not counting white space)." 15 | (equal (current-indentation) 16 | (eri-current-line-length))) 17 | 18 | (defun eri-maximum (xs) 19 | "Calculate maximum element in XS. Return nil if the list is empty." 20 | (if xs (apply 'max xs))) 21 | 22 | (defun eri-take (n xs) 23 | "Return the first N elements of XS." 24 | (butlast xs (- (length xs) n))) 25 | 26 | (defun eri-split (x xs) 27 | "Return a pair of lists (XS1 . XS2). 28 | If XS is sorted, then XS = (append XS1 XS2), and all elements in XS1 are <= X, 29 | whereas all elements in XS2 are > X." 30 | (let* ((pos (or (position-if (lambda (y) (> y x)) xs) (length xs))) 31 | (xs1 (eri-take pos xs)) 32 | (xs2 (nthcdr pos xs))) 33 | `(,xs1 . ,xs2))) 34 | 35 | (defun eri-calculate-indentation-points-on-line (max) 36 | "Calculate indentation points on current line. 37 | Only points left of column number MAX are included. 38 | If MAX is nil, then all points are included. Return points in ascending order. 39 | 40 | Example (positions marked with ^ are returned): 41 | 42 | f x y = g 3 (Just y) 5 4 43 | ^ ^ ^ ^ ^ ^ ^ ^ | 44 | | 45 | MAX" 46 | (let ((result)) 47 | (save-restriction 48 | (beginning-of-line) 49 | ; To make \\` work in the regexp below: 50 | (narrow-to-region (line-beginning-position) (line-end-position)) 51 | (while 52 | (progn 53 | (let ((pos (and (search-forward-regexp 54 | "\\(?:\\s-\\|\\`\\)\\(\\S-\\)" nil t) 55 | (match-beginning 1)))) 56 | (when (not (null pos)) 57 | (let ((pos1 (- pos (line-beginning-position)))) 58 | (when (or (null max) (< pos1 max)) 59 | (add-to-list 'result pos1)))) 60 | (and pos 61 | (< (point) (line-end-position)) 62 | (or (null max) (< (current-column) max)))))) 63 | (nreverse result) ; Destructive operation. 64 | ))) 65 | 66 | (defun eri-new-indentation-point () 67 | "Calculate a new indentation point, two steps in from the 68 | indentation of the first non-empty line above the current line. 69 | If there is no such line 2 is returned." 70 | (save-excursion 71 | (while 72 | (progn 73 | (forward-line -1) 74 | (not (or (bobp) 75 | (not (eri-current-line-empty)))))) 76 | (+ 2 (current-indentation)))) 77 | 78 | (defun eri-calculate-indentation-points (reverse) 79 | "Calculate some indentation points. Gives them in reverse order if 80 | REVERSE is non-nil. See `eri-indent' for a description of how 81 | the indentation points are calculated." 82 | ;; First find a bunch of indentations used above the current line. 83 | (let ((points) 84 | (max)) 85 | (save-excursion 86 | (while 87 | (progn 88 | (forward-line -1) 89 | ; Skip lines with only white space. 90 | (unless (eri-current-line-empty) 91 | (setq points 92 | (append 93 | (eri-calculate-indentation-points-on-line max) 94 | points)) 95 | (setq max (car points))) 96 | ;; Stop after hitting the beginning of the buffer or a 97 | ;; non-empty, non-indented line. 98 | (not (or (bobp) 99 | (and (equal (current-indentation) 0) 100 | (> (eri-current-line-length) 0))))))) 101 | ;; Add a new indentation point. Sort the indentations. 102 | ;; Rearrange the points so that the next point is the one after the 103 | ;; current one. 104 | (let* ((ps (add-to-list 'points (eri-new-indentation-point))) 105 | (ps1 (sort ps '<)) ; Note: sort is destructive. 106 | (ps2 (eri-split (current-indentation) 107 | (remove (current-indentation) ps1)))) 108 | (if reverse 109 | (append (nreverse (car ps2)) (nreverse (cdr ps2))) 110 | (append (cdr ps2) (car ps2)))))) 111 | 112 | (defun eri-indent (&optional reverse) 113 | "Cycle between some possible indentation points. 114 | With prefix argument REVERSE, cycle in reverse order. 115 | 116 | Assume that a file contains the following lines of code, with point on 117 | the line with three dots: 118 | 119 | frob = loooooooooooooooooooooooooong identifier 120 | foo = f a b 121 | where 122 | f (Foo x) y = let bar = x 123 | baz = 3 + 5 124 | 125 | ... 126 | 127 | ^ ^ ^ ^ ^ ^ ^ ^ ^ * ^ ^ ^ ^ 128 | 129 | Then the ^'s and the * mark the indentation points that this function 130 | cycles through. The indentation points are selected as follows: 131 | 132 | * All lines before the current one, up to and including the first 133 | non-indented line (or the beginning of the buffer) are considered. 134 | 135 | foo = f a b 136 | where 137 | f (Foo x) y = let bar = x 138 | baz = 3 + 5 139 | 140 | * On these lines, erase all characters that stand to the right of 141 | some non-white space character on a lower line. 142 | 143 | foo 144 | whe 145 | f (Foo x) y = let b 146 | baz = 3 + 5 147 | 148 | * Also erase all characters not immediately preceded by white 149 | space. 150 | 151 | f 152 | w 153 | f ( x y = l b 154 | b = 3 + 5 155 | 156 | * The columns of all remaining characters are indentation points. 157 | 158 | f w f ( x y = l b = 3 + 5 159 | ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ ^ 160 | 161 | * A new indentation point is also added, two steps in from the 162 | indentation of the first non-empty line above the current line 163 | (or in the second column, if there is no such line). 164 | 165 | f w f ( x y = l b = 3 + 5 166 | ^ ^ ^ ^ ^ ^ ^ ^ ^ * ^ ^ ^ ^" 167 | (interactive "P") 168 | (let* ((points (eri-calculate-indentation-points reverse)) 169 | (remaining-points (cdr (member (current-indentation) points))) 170 | (indentation (if remaining-points 171 | (car remaining-points) 172 | (car points)))) 173 | (when indentation 174 | (save-excursion (indent-line-to indentation)) 175 | (if (< (current-column) indentation) 176 | (indent-line-to indentation))))) 177 | 178 | (defun eri-indent-reverse nil 179 | "Cycle between some possible indentation points (in reverse order). 180 | See `eri-indent' for a description of how the indentation points are 181 | calculated." 182 | (interactive) 183 | (eri-indent t)) 184 | 185 | (provide 'eri) 186 | ;;; eri.el ends here 187 | -------------------------------------------------------------------------------- /modes/agda2/annotation.el: -------------------------------------------------------------------------------- 1 | ;;; annotation.el --- Functions for annotating text with faces and help bubbles 2 | 3 | ;;; Commentary: 4 | ;; 5 | 6 | ;;; Code: 7 | (require 'cl) 8 | 9 | (defconst annotations-offset (- (save-restriction (widen) (point-min)) 1) 10 | "Offset between buffer positions and annotations's positions. 11 | Annotations's positions are based on 1, so this adjusts it to the base 12 | position used by your Emacs.") 13 | 14 | (defvar annotation-bindings nil 15 | "An association list mapping symbols to faces.") 16 | (make-variable-buffer-local 'annotation-bindings) 17 | 18 | (defvar annotation-goto-stack nil 19 | "Positions from which `annotation-goto' was invoked.") 20 | 21 | (defun annotation-goto-possible (pos) 22 | "Return t if there's a hyperlink at the buffer position POS, and nil otherwise." 23 | (if (get-text-property pos 'annotation-goto) t)) 24 | 25 | (defun annotation-goto-indirect (pos &optional other-window) 26 | "Follow the `annotation-goto' hyperlink at position POS, if any. 27 | If OTHER-WINDOW is t, use another window to display the given position." 28 | (let ((previous-file-name buffer-file-name)) 29 | (if (and (annotation-goto (get-text-property pos 'annotation-goto) 30 | other-window) 31 | (not (eq (point) pos))) 32 | (push `(,previous-file-name . ,pos) annotation-goto-stack)))) 33 | 34 | (defun annotation-go-back nil 35 | "Go back to the previous position in which `annotation-goto' was 36 | successfully invoked." 37 | (when annotation-goto-stack 38 | (let ((pos (pop annotation-goto-stack))) 39 | (annotation-goto pos)))) 40 | 41 | (defun annotation-goto (filepos &optional other-window) 42 | "Go to file position FILEPOS if the file is readable. 43 | FILEPOS should have the form (FILE . POS). Return t if successful. 44 | 45 | If OTHER-WINDOW is t, use another window to display the given 46 | position." 47 | (when (consp filepos) 48 | (let ((file (car filepos))) 49 | (if (file-readable-p file) 50 | (progn 51 | (if other-window 52 | (find-file-other-window file) 53 | (find-file file)) 54 | (goto-char (+ (cdr filepos) annotations-offset)) 55 | t) 56 | (error "File does not exist or is unreadable: %s." file))))) 57 | 58 | (defun annotation-annotate (start end anns &optional info goto) 59 | "Annotate text between START and END in the current buffer. 60 | ANNS are the annotations to apply. 61 | All the symbols in ANNS are looked up in 62 | `annotation-bindings', and the face text property for the given 63 | character range is set to the resulting list of faces. If the string 64 | INFO is non-nil, the mouse-face property is set to highlight, and INFO 65 | is used as the help-echo string. If GOTO has the form (FILENAME . 66 | POSITION), then the mouse-face property is set to highlight and, when 67 | the user clicks on the annotated text, then point is warped to the 68 | given position in the given file. 69 | 70 | Note that if two faces have the same attribute set, then the first one 71 | takes precedence. 72 | 73 | Note also that setting the face text property does not work when 74 | `font-lock-mode' is activated. 75 | 76 | All characters whose text properties get set also have the 77 | annotation-annotated property set to t, and 78 | annotation-annotations is set to a list with all the properties 79 | that have been set; this ensures that the text properties can 80 | later be removed (if the annotation-* properties are not tampered 81 | with). 82 | 83 | Note finally that nothing happens if either START or END are out of 84 | bounds for the current (possibly narrowed) buffer, or END < START." 85 | (incf start annotations-offset) 86 | (incf end annotations-offset) 87 | (when (and (<= (point-min) start) 88 | (<= start end) 89 | (<= end (point-max))) 90 | (let ((faces (delq nil 91 | (mapcar (lambda (ann) 92 | (cdr (assoc ann annotation-bindings))) 93 | anns))) 94 | (props nil)) 95 | (when faces 96 | (put-text-property start end 'face faces) 97 | (add-to-list 'props 'face)) 98 | ;; Do this before so `info' can override our default help-echo. 99 | (when (consp goto) 100 | (add-text-properties start end 101 | `(annotation-goto ,goto 102 | mouse-face highlight 103 | help-echo "Click mouse-2 to jump to definition")) 104 | (add-to-list 'props 'annotation-goto) 105 | (add-to-list 'props 'mouse-face) 106 | (add-to-list 'props 'help-echo)) 107 | (when info 108 | (add-text-properties start end 109 | `(mouse-face highlight help-echo ,info)) 110 | (add-to-list 'props 'mouse-face) 111 | (add-to-list 'props 'help-echo)) 112 | (when props 113 | (add-text-properties start end 114 | `(annotation-annotated t 115 | annotation-annotations ,props)))))) 116 | 117 | (defmacro annotation-preserve-mod-p-and-undo (&rest code) 118 | "Run CODE preserving both its undo data and modification bit." 119 | (let ((modp (make-symbol "modp"))) 120 | `(let ((,modp (buffer-modified-p)) 121 | (buffer-undo-list t)) 122 | (unwind-protect 123 | (progn ,@code) 124 | ;; FIXME: `restore-buffer-modified-p' would be more efficient. 125 | (set-buffer-modified-p ,modp))))) 126 | 127 | (defun annotation-remove-annotations () 128 | "Remove all text properties set by `annotation-annotate' in the current buffer. 129 | This function preserves the file modification stamp of the current buffer 130 | and does not modify the undo list. 131 | 132 | Note: This function may fail if there is read-only text in the buffer." 133 | 134 | ;; remove-text-properties fails for read-only text. 135 | 136 | (annotation-preserve-mod-p-and-undo 137 | (let ((pos (point-min)) 138 | pos2) 139 | (while pos 140 | (setq pos2 (next-single-property-change pos 'annotation-annotated)) 141 | (let ((props (get-text-property pos 'annotation-annotations))) 142 | (when props 143 | (remove-text-properties pos (or pos2 (point-max)) 144 | (mapcan (lambda (prop) (list prop nil)) 145 | (append '(annotation-annotated annotation-annotations) 146 | props))))) 147 | (setq pos pos2))))) 148 | 149 | (defun annotation-load-file (file) 150 | "Load and execute FILE, which should contain calls to `annotation-annotate'. 151 | First all existing text properties set by `annotation-annotate' 152 | in the current buffer are removed. This function preserves the 153 | file modification stamp of the current buffer and does not 154 | modify the undo list. 155 | 156 | Note: This function may fail if there is read-only text in the buffer." 157 | (annotation-preserve-mod-p-and-undo 158 | (annotation-remove-annotations) 159 | (when (file-readable-p file) 160 | ;; FIXME: Giant security hole!! 161 | ;; (load file nil 'nomessage) 162 | (let ((cmds (with-temp-buffer 163 | (insert "(\n)") (forward-char -2) 164 | (insert-file-contents file) 165 | (goto-char (point-min)) 166 | (read (current-buffer))))) 167 | (dolist (cmd cmds) 168 | (destructuring-bind (f start end anns &optional info goto) cmd 169 | (assert (eq f 'annotation-annotate)) 170 | (setq anns (cadr anns)) ;Strip the `quote'. 171 | (setq goto (cadr goto)) ;Strip the `quote'. 172 | (annotation-annotate start end anns info goto))))))) 173 | 174 | (provide 'annotation) 175 | ;;; annotation.el ends here 176 | -------------------------------------------------------------------------------- /customizations.el: -------------------------------------------------------------------------------- 1 | 2 | ;; for compatibility with older Aquamacs versions 3 | (defvar aquamacs-140-custom-file-upgraded t) 4 | (unless (fboundp 'auto-detect-longlines) (defun auto-detect-longlines () t)) 5 | (custom-set-variables 6 | ;; custom-set-variables was added by Custom. 7 | ;; If you edit it by hand, you could mess it up, so be careful. 8 | ;; Your init file should contain only one such instance. 9 | ;; If there is more than one, they won't work right. 10 | '(agda2-include-dirs (quote ("/Users/mbolingbroke/Programming/Checkouts/AgdaStdLib/src" "."))) 11 | '(aquamacs-additional-fontsets nil t) 12 | '(aquamacs-customization-version-id 190 t) 13 | '(aquamacs-default-styles (quote ((haskell-mode (color-theme color-theme-snapshot ((background-color . "black") (background-mode . dark) (border-color . "black") (cursor-color . "white") (foreground-color . "white") (mouse-color . "black")) ((cua-global-mark-cursor-color . "cyan") (cua-normal-cursor-color . "red") (cua-overwrite-cursor-color . "yellow") (cua-read-only-cursor-color . "darkgreen") (list-matching-lines-buffer-name-face . underline) (list-matching-lines-face . match) (rmail-highlight-face . rmail-highlight) (view-highlight-face . highlight) (widget-mouse-face . highlight)) (default ((t (:stipple nil :background "black" :foreground "white" :inverse-video nil :box nil :strike-through nil :overline nil :underline nil :slant normal :weight normal :height 120 :width normal :family "apple-monaco")))) (aquamacs-variable-width ((t (:height 120 :family "Lucida Grande")))) (bold ((t (:bold t :weight bold)))) (bold-italic ((t (:italic t :slant italic :weight bold)))) (border ((t (:background "black")))) (buffer-menu-buffer ((t (:bold t :weight bold)))) (button ((t (:underline t)))) (change-log-acknowledgement ((t (:italic t :slant italic :foreground "#9933cc")))) (change-log-conditionals ((t (:foreground "#aaccff")))) (change-log-date ((t (:foreground "#66FF00")))) (change-log-email ((t (:foreground "#aaccff")))) (change-log-file ((t (:foreground "#ffcc00")))) (change-log-function ((t (:foreground "#aaccff")))) (change-log-list ((t (:foreground "#ff6600")))) (change-log-name ((t (:foreground "#339999")))) (completions-common-part ((t (:family "apple-monaco" :width normal :weight normal :slant normal :underline nil :overline nil :strike-through nil :box nil :inverse-video nil :foreground "white" :background "black" :stipple nil :height 120)))) (completions-first-difference ((t (:bold t :weight bold)))) (cua-global-mark ((t (:background "yellow1" :foreground "black")))) (cua-rectangle ((t (:background "maroon" :foreground "white")))) (cua-rectangle-noselect ((t (:background "dimgray" :foreground "white")))) (cursor ((t (:background "white")))) (custom-button ((t (:background "lightgrey" :foreground "black" :box (:line-width 2 :style released-button))))) (custom-button-mouse ((t (:background "grey90" :foreground "black" :box (:line-width 2 :style released-button))))) (custom-button-pressed ((t (:background "lightgrey" :foreground "black" :box (:line-width 2 :style pressed-button))))) (custom-button-pressed-unraised ((t (:underline t :foreground "violet")))) (custom-button-unraised ((t (:underline t)))) (custom-changed ((t (:background "blue1" :foreground "white")))) (custom-comment ((t (:background "dim gray")))) (custom-comment-tag ((t (:foreground "gray80")))) (custom-documentation ((t (nil)))) (custom-face-tag ((t (:bold t :family "helv" :weight bold :height 1.2)))) (custom-group-tag ((t (:bold t :foreground "light blue" :weight bold :height 1.2)))) (custom-group-tag-1 ((t (:bold t :family "helv" :foreground "pink" :weight bold :height 1.2)))) (custom-invalid ((t (:background "red1" :foreground "yellow1")))) (custom-link ((t (:underline t :foreground "cyan1")))) (custom-modified ((t (:background "blue1" :foreground "white")))) (custom-rogue ((t (:background "black" :foreground "pink")))) (custom-saved ((t (:underline t)))) (custom-set ((t (:background "white" :foreground "blue1")))) (custom-state ((t (:foreground "lime green")))) (custom-themed ((t (:background "blue1" :foreground "white")))) (custom-variable-button ((t (:bold t :underline t :weight bold)))) (custom-variable-tag ((t (:bold t :family "helv" :foreground "light blue" :weight bold :height 1.2)))) (darcsum-change-line-face ((t (:background "grey25" :foreground "grey75")))) (darcsum-filename-face ((t (:foreground "lightblue")))) (darcsum-header-face ((t (:bold t :foreground "blue4" :weight bold)))) (darcsum-marked-face ((t (:bold t :weight bold)))) (darcsum-need-action-face ((t (:foreground "orange")))) (darcsum-need-action-marked-face ((t (:bold t :foreground "orange" :weight bold)))) (darcsum-whitespace-ateol-face ((t (:background "red4")))) (escape-glyph ((t (:foreground "cyan")))) (file-name-shadow ((t (:foreground "grey70")))) (fixed-pitch ((t (:family "courier")))) (flymake-errline ((t (:background "LightSalmon" :foreground "black")))) (flymake-warnline ((t (:background "LightSteelBlue" :foreground "black")))) (font-lock-builtin-face ((t (:foreground "#aaccff")))) (font-lock-comment-delimiter-face ((t (:foreground "#9933cc")))) (font-lock-comment-face ((t (:italic t :foreground "#9933cc" :slant italic)))) (font-lock-constant-face ((t (:foreground "#339999")))) (font-lock-doc-face ((t (:foreground "LightSalmon")))) (font-lock-function-name-face ((t (:foreground "#ffcc00")))) (font-lock-keyword-face ((t (:foreground "#ff6600")))) (font-lock-negation-char-face ((t (nil)))) (font-lock-preprocessor-face ((t (:foreground "#aaffff")))) (font-lock-reference-face ((t (:foreground "LightSteelBlue")))) (font-lock-regexp-grouping-backslash ((t (:bold t :weight bold)))) (font-lock-regexp-grouping-construct ((t (:bold t :weight bold)))) (font-lock-string-face ((t (:foreground "#66FF00")))) (font-lock-type-face ((t (:italic t :foreground "#aaaaaa" :slant italic)))) (font-lock-variable-name-face ((t (:foreground "#aaccff")))) (font-lock-warning-face ((t (:bold t :foreground "Pink" :weight bold)))) (fringe ((t (:background "black")))) (header-line ((t (:width normal :weight normal :slant normal :underline nil :strike-through nil :family "Lucida Grande" :background "grey20" :foreground "grey90" :box nil :height 120)))) (help-argument-name ((t (:italic t :slant italic)))) (highlight ((t (:background "darkolivegreen")))) (ido-first-match ((t (:bold t :weight bold)))) (ido-incomplete-regexp ((t (:bold t :weight bold :foreground "Pink")))) (ido-indicator ((t (:background "red1" :foreground "yellow1" :width condensed)))) (ido-only-match ((t (:foreground "ForestGreen")))) (ido-subdir ((t (:foreground "red1")))) (isearch ((t (:background "#555555")))) (italic ((t (:italic t :slant italic)))) (lazy-highlight ((t (:background "paleturquoise4")))) (link ((t (:foreground "cyan1" :underline t)))) (link-visited ((t (:underline t :foreground "violet")))) (mac-ts-block-fill-text ((t (:underline t)))) (mac-ts-caret-position ((t (nil)))) (mac-ts-converted-text ((t (:underline "gray20")))) (mac-ts-no-hilite ((t (:family "apple-monaco" :width normal :weight normal :slant normal :underline nil :overline nil :strike-through nil :box nil :inverse-video nil :foreground "white" :background "black" :stipple nil :height 120)))) (mac-ts-outline-text ((t (:underline t)))) (mac-ts-raw-text ((t (:underline t)))) (mac-ts-selected-converted-text ((t (:underline t)))) (mac-ts-selected-raw-text ((t (:underline t)))) (mac-ts-selected-text ((t (:underline t)))) (match ((t (:background "RoyalBlue3")))) (menu ((t (nil)))) (minibuffer-prompt ((t (:bold t :foreground "#ff6600" :weight bold)))) (mode-line ((t (:family "Lucida Grande" :background "#a5baf1" :foreground "black" :strike-through nil :underline nil :slant normal :weight normal :width normal :height 120)))) (mode-line-buffer-id ((t (:background "#a5baf1" :foreground "black")))) (mode-line-flags ((t (:family "Monaco")))) (mode-line-highlight ((t (:box (:line-width 2 :color "grey40" :style released-button))))) (mode-line-inactive ((t (:family "Lucida Grande" :background "grey90" :foreground "grey20" :box (:line-width -1 :color "grey75" :style nil) :strike-through nil :underline nil :slant normal :weight normal :width normal :height 120)))) (modeline-mousable ((t (:background "#a5baf1" :foreground "black")))) (modeline-mousable-minor-mode ((t (:background "#a5baf1" :foreground "black")))) (mouse ((t (:background "black")))) (next-error ((t (:background "#555577")))) (nobreak-space ((t (:foreground "cyan" :underline t)))) (notify-user-of-mode ((t (:foreground "cyan")))) (paren-face-match-light ((t (:background "#222222")))) (primary-selection ((t (:background "#555577")))) (query-replace ((t (:background "#555555")))) (region ((t (:background "#555577")))) (scroll-bar ((t (nil)))) (secondary-selection ((t (:background "darkslateblue")))) (shadow ((t (:foreground "grey70")))) (show-paren-match ((t (:background "steelblue3")))) (show-paren-mismatch ((t (:background "purple" :foreground "white")))) (tool-bar ((t (:background "#eaeaea" :foreground "black" :box (:line-width 1 :style released-button))))) (tooltip ((t (:background "lightyellow" :foreground "black" :height 100 :family "lucida sans")))) (trailing-whitespace ((t (:background "red1")))) (underline ((t (:underline t)))) (variable-pitch ((t (:family "helv")))) (vertical-border ((t (nil)))) (widget-button ((t (:bold t :weight bold)))) (widget-button-pressed ((t (:foreground "red1")))) (widget-documentation ((t (:foreground "lime green")))) (widget-field ((t (:background "dim gray")))) (widget-inactive ((t (:foreground "grey70")))) (widget-single-line-field ((t (:background "dim gray")))) (zmacs-region ((t (:background "#555577"))))) (font . "-*-*-medium-r-normal-*-12-*-*-*-*-*-fontset-monaco12") (tool-bar-lines . 1)) (help-mode (tool-bar-lines . 0)) (text-mode (font . "fontset-lucida13")) (change-log-mode (font . "fontset-lucida13")) (tex-mode (font . "fontset-lucida13")) (outline-mode (font . "fontset-lucida13")) (paragraph-indent-text-mode (font . "fontset-lucida13")) (speedbar-mode (minibuffer-auto-raise)) (custom-mode (tool-bar-lines . 0) (fit-frame . t) (font . "fontset-monaco11") (foreground-color . "sienna") (background-color . "light goldenrod"))))) 14 | '(aquamacs-styles-mode t nil (color-theme)) 15 | '(tabbar-mode nil nil (tabbar)) 16 | '(transient-mark-mode t)) 17 | (custom-set-faces 18 | ;; custom-set-faces was added by Custom. 19 | ;; If you edit it by hand, you could mess it up, so be careful. 20 | ;; Your init file should contain only one such instance. 21 | ;; If there is more than one, they won't work right. 22 | ) 23 | -------------------------------------------------------------------------------- /modes/agda2/agda2-highlight.el: -------------------------------------------------------------------------------- 1 | ;;; agda2-highlight.el --- Syntax highlighting for Agda (version ≥ 2) 2 | 3 | ;;; Commentary: 4 | 5 | ;; Code to apply syntactic highlighting to Agda source code. This uses 6 | ;; Agda's own annotations to figure out what is what, so the parsing 7 | ;; is always done correctly, but highlighting is not done on the fly. 8 | 9 | ;;; Code: 10 | 11 | (require 'annotation) 12 | (require 'font-lock) 13 | 14 | (defgroup agda2-highlight nil 15 | "Syntax highlighting for Agda." 16 | :group 'agda2) 17 | 18 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 19 | ;; Functions for setting faces 20 | 21 | (defun agda2-highlight-set-face-attribute (face attrs) 22 | "Reset (globally) all attributes of the face FACE according to ATTRS. 23 | If the face does not exist, then it is created first." 24 | (make-face face) 25 | (set-face-attribute face nil 26 | :family 'unspecified 27 | :width 'unspecified 28 | :height 'unspecified 29 | :weight 'unspecified 30 | :slant 'unspecified 31 | :foreground 'unspecified 32 | :background 'unspecified 33 | :inverse-video 'unspecified 34 | :stipple 'unspecified 35 | :underline 'unspecified 36 | :overline 'unspecified 37 | :strike-through 'unspecified 38 | :inherit 'unspecified 39 | :box 'unspecified 40 | :font 'unspecified) 41 | (eval `(set-face-attribute face nil ,@attrs))) 42 | 43 | (defun agda2-highlight-set-faces (variable group) 44 | "Set all Agda faces according to the value of GROUP. 45 | Also sets the default value of VARIABLE to GROUP." 46 | (set-default variable group) 47 | (mapc (lambda (face-and-attrs) 48 | (agda2-highlight-set-face-attribute 49 | (car face-and-attrs) (cdr face-and-attrs))) 50 | (cond 51 | ((equal group 'conor) 52 | '((agda2-highlight-comment-face 53 | :foreground "gray35") 54 | (agda2-highlight-keyword-face 55 | :underline t) 56 | (agda2-highlight-string-face) 57 | (agda2-highlight-number-face) 58 | (agda2-highlight-symbol-face) 59 | (agda2-highlight-primitive-type-face 60 | :foreground "blue") 61 | (agda2-highlight-bound-variable-face 62 | :foreground "purple") 63 | (agda2-highlight-inductive-constructor-face 64 | :foreground "dark red") 65 | (agda2-highlight-coinductive-constructor-face 66 | :foreground "dark red") 67 | (agda2-highlight-datatype-face 68 | :foreground "blue") 69 | (agda2-highlight-field-face 70 | :foreground "dark red") 71 | (agda2-highlight-function-face 72 | :foreground "dark green") 73 | (agda2-highlight-module-face 74 | :foreground "dark green") 75 | (agda2-highlight-postulate-face 76 | :foreground "dark green") 77 | (agda2-highlight-primitive-face 78 | :foreground "dark green") 79 | (agda2-highlight-record-face 80 | :foreground "blue") 81 | (agda2-highlight-dotted-face) 82 | (agda2-highlight-error-face 83 | :foreground "black" 84 | :background "sandy brown") 85 | (agda2-highlight-unsolved-meta-face 86 | :foreground "black" 87 | :background "gold") 88 | (agda2-highlight-termination-problem-face 89 | :foreground "black" 90 | :background "red") 91 | (agda2-highlight-incomplete-pattern-face 92 | :foreground "black" 93 | :background "purple")))))) 94 | 95 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 96 | ;; Faces 97 | 98 | (defcustom agda2-highlight-face-groups nil 99 | "Colour scheme to use for agda2 highlight faces. 100 | Note that changing this option does not remove the customisations 101 | below; you can get them back by resetting this option and 102 | restarting Emacs." 103 | :type '(choice 104 | (const :tag "Use the settings below." nil) 105 | (const :tag "Use an approximation of Conor McBride's colour scheme." 106 | conor)) 107 | :group 'agda2-highlight 108 | :set 'agda2-highlight-set-faces) 109 | 110 | (defface agda2-highlight-comment-face 111 | '((t (:foreground "firebrick"))) 112 | "The face used for comments." 113 | :group 'agda2-highlight) 114 | 115 | (defface agda2-highlight-keyword-face 116 | '((t (:foreground "DarkOrange3"))) 117 | "The face used for keywords." 118 | :group 'agda2-highlight) 119 | 120 | (defface agda2-highlight-string-face 121 | '((t (:foreground "firebrick"))) 122 | "The face used for strings." 123 | :group 'agda2-highlight) 124 | 125 | (defface agda2-highlight-number-face 126 | '((t (:foreground "purple"))) 127 | "The face used for numbers." 128 | :group 'agda2-highlight) 129 | 130 | (defface agda2-highlight-symbol-face 131 | '((((background light)) 132 | (:foreground "gray25")) 133 | (((background dark)) 134 | (:foreground "gray75"))) 135 | "The face used for symbols like forall, =, ->, etc." 136 | :group 'agda2-highlight) 137 | 138 | (defface agda2-highlight-primitive-type-face 139 | '((t (:foreground "medium blue"))) 140 | "The face used for primitive types (like Set and Prop)." 141 | :group 'agda2-highlight) 142 | 143 | (defface agda2-highlight-bound-variable-face 144 | '((t nil)) 145 | "The face used for bound variables." 146 | :group 'agda2-highlight) 147 | 148 | (defface agda2-highlight-inductive-constructor-face 149 | '((t (:foreground "green4"))) 150 | "The face used for inductive constructors." 151 | :group 'agda2-highlight) 152 | 153 | (defface agda2-highlight-coinductive-constructor-face 154 | '((t (:foreground "gold4"))) 155 | "The face used for coinductive constructors." 156 | :group 'agda2-highlight) 157 | 158 | (defface agda2-highlight-datatype-face 159 | '((t (:foreground "medium blue"))) 160 | "The face used for datatypes." 161 | :group 'agda2-highlight) 162 | 163 | (defface agda2-highlight-field-face 164 | '((t (:foreground "DeepPink2"))) 165 | "The face used for record fields." 166 | :group 'agda2-highlight) 167 | 168 | (defface agda2-highlight-function-face 169 | '((t (:foreground "medium blue"))) 170 | "The face used for functions." 171 | :group 'agda2-highlight) 172 | 173 | (defface agda2-highlight-module-face 174 | '((t (:foreground "purple"))) 175 | "The face used for module names." 176 | :group 'agda2-highlight) 177 | 178 | (defface agda2-highlight-postulate-face 179 | '((t (:foreground "medium blue"))) 180 | "The face used for postulates." 181 | :group 'agda2-highlight) 182 | 183 | (defface agda2-highlight-primitive-face 184 | '((t (:foreground "medium blue"))) 185 | "The face used for primitive functions." 186 | :group 'agda2-highlight) 187 | 188 | (defface agda2-highlight-record-face 189 | '((t (:foreground "medium blue"))) 190 | "The face used for record types." 191 | :group 'agda2-highlight) 192 | 193 | (defface agda2-highlight-dotted-face 194 | '((t nil)) 195 | "The face used for dotted patterns." 196 | :group 'agda2-highlight) 197 | 198 | (defface agda2-highlight-operator-face 199 | '((t nil)) 200 | "The face used for operators." 201 | :group 'agda2-highlight) 202 | 203 | (defface agda2-highlight-error-face 204 | '((t (:foreground "red" :underline t))) 205 | "The face used for errors." 206 | :group 'agda2-highlight) 207 | 208 | (defface agda2-highlight-unsolved-meta-face 209 | '((t (:background "yellow" 210 | :foreground "black"))) 211 | "The face used for unsolved meta variables." 212 | :group 'agda2-highlight) 213 | 214 | (defface agda2-highlight-termination-problem-face 215 | '((t (:background "light salmon" 216 | :foreground "black"))) 217 | "The face used for termination problems." 218 | :group 'agda2-highlight) 219 | 220 | (defface agda2-highlight-incomplete-pattern-face 221 | '((t (:background "wheat" 222 | :foreground "black"))) 223 | "The face used for incomplete patterns. (Currently unused.)" 224 | :group 'agda2-highlight) 225 | 226 | (defvar agda2-highlight-faces 227 | '((comment . agda2-highlight-comment-face) 228 | (keyword . agda2-highlight-keyword-face) 229 | (string . agda2-highlight-string-face) 230 | (number . agda2-highlight-number-face) 231 | (symbol . agda2-highlight-symbol-face) 232 | (primitivetype . agda2-highlight-primitive-type-face) 233 | (bound . agda2-highlight-bound-variable-face) 234 | (inductiveconstructor . agda2-highlight-inductive-constructor-face) 235 | (coinductiveconstructor . agda2-highlight-coinductive-constructor-face) 236 | (datatype . agda2-highlight-datatype-face) 237 | (field . agda2-highlight-field-face) 238 | (function . agda2-highlight-function-face) 239 | (module . agda2-highlight-module-face) 240 | (postulate . agda2-highlight-postulate-face) 241 | (primitive . agda2-highlight-primitive-face) 242 | (record . agda2-highlight-record-face) 243 | (dotted . agda2-highlight-dotted-face) 244 | (operator . agda2-highlight-operator-face) 245 | (error . agda2-highlight-error-face) 246 | (unsolvedmeta . agda2-highlight-unsolved-meta-face) 247 | (terminationproblem . agda2-highlight-termination-problem-face) 248 | (incompletepattern . agda2-highlight-incomplete-pattern-face)) 249 | "Alist mapping code aspects to the face used when displaying them. 250 | 251 | The aspects currently recognised are the following: 252 | 253 | `bound' Bound variables. 254 | `coinductiveconstructor' Coinductive constructors. 255 | `comment' Comments. 256 | `datatype' Data types. 257 | `dotted' Dotted patterns. 258 | `error' Errors. 259 | `field' Record fields. 260 | `function' Functions. 261 | `incompletepattern' Incomplete patterns. 262 | `inductiveconstructor' Inductive constructors. 263 | `keyword' Keywords. 264 | `module' Module names. 265 | `number' Numbers. 266 | `operator' Operators. 267 | `postulate' Postulates. 268 | `primitive' Primitive functions. 269 | `primitivetype' Primitive types (like Set and Prop). 270 | `record' Record types. 271 | `string' Strings. 272 | `symbol' Symbols like forall, =, ->, etc. 273 | `terminationproblem' Termination problems. 274 | `unsolvedmeta' Unsolved meta variables.") 275 | 276 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 277 | ;; Functions 278 | 279 | (defun agda2-highlight-reload nil 280 | "Reload current buffer's syntax information from the syntax file." 281 | (interactive) 282 | (let* ((dir (file-name-directory buffer-file-name)) 283 | (name (file-name-nondirectory buffer-file-name)) 284 | (file (concat dir "." name ".el")) 285 | (inhibit-read-only t)) 286 | ; Ignore read-only status, otherwise this function may fail. 287 | (annotation-load-file file))) 288 | 289 | (defun agda2-highlight-setup nil 290 | "Set up the `annotation' library for use with `agda2-mode'." 291 | (font-lock-mode 0) 292 | (setq annotation-bindings agda2-highlight-faces)) 293 | 294 | (defun agda2-highlight-clear nil 295 | "Remove all syntax highlighting added by `agda2-highlight-reload'." 296 | (interactive) 297 | (let ((inhibit-read-only t)) 298 | ; Ignore read-only status, otherwise this function may fail. 299 | (annotation-remove-annotations))) 300 | 301 | (defun agda2-highlight-reload-or-clear (&optional arg) 302 | "Reload syntax highlighting information. 303 | With prefix argument ARG: Remove syntax highlighting." 304 | (interactive "P") 305 | (if arg (agda2-highlight-clear) 306 | (agda2-highlight-reload))) 307 | 308 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 309 | ;; Administrative details 310 | 311 | (provide 'agda2-highlight) 312 | ;;; agda2-highlight.el ends here 313 | -------------------------------------------------------------------------------- /json.el: -------------------------------------------------------------------------------- 1 | ;;; json.el --- JavaScript Object Notation parser / generator 2 | 3 | ;; Copyright (C) 2006, 2007, 2008, 2009 Free Software Foundation, Inc. 4 | 5 | ;; Author: Edward O'Connor 6 | ;; Version: 1.2 7 | ;; Keywords: convenience 8 | 9 | ;; This file is part of GNU Emacs. 10 | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify 12 | ;; it under the terms of the GNU General Public License as published by 13 | ;; the Free Software Foundation, either version 3 of the License, or 14 | ;; (at your option) any later version. 15 | 16 | ;; GNU Emacs is distributed in the hope that it will be useful, 17 | ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | ;; GNU General Public License for more details. 20 | 21 | ;; You should have received a copy of the GNU General Public License 22 | ;; along with GNU Emacs. If not, see . 23 | 24 | ;;; Commentary: 25 | 26 | ;; This is a library for parsing and generating JSON (JavaScript Object 27 | ;; Notation). 28 | 29 | ;; Learn all about JSON here: . 30 | 31 | ;; The user-serviceable entry points for the parser are the functions 32 | ;; `json-read' and `json-read-from-string'. The encoder has a single 33 | ;; entry point, `json-encode'. 34 | 35 | ;; Since there are several natural representations of key-value pair 36 | ;; mappings in elisp (alist, plist, hash-table), `json-read' allows you 37 | ;; to specify which you'd prefer (see `json-object-type' and 38 | ;; `json-array-type'). 39 | 40 | ;; Similarly, since `false' and `null' are distinct in JSON, you can 41 | ;; distinguish them by binding `json-false' and `json-null' as desired. 42 | 43 | ;;; History: 44 | 45 | ;; 2006-03-11 - Initial version. 46 | ;; 2006-03-13 - Added JSON generation in addition to parsing. Various 47 | ;; other cleanups, bugfixes, and improvements. 48 | ;; 2006-12-29 - XEmacs support, from Aidan Kehoe . 49 | ;; 2008-02-21 - Installed in GNU Emacs. 50 | 51 | ;;; Code: 52 | 53 | (eval-when-compile (require 'cl)) 54 | 55 | ;; Compatibility code 56 | 57 | (defalias 'json-encode-char0 'encode-char) 58 | (defalias 'json-decode-char0 'decode-char) 59 | 60 | 61 | ;; Parameters 62 | 63 | (defvar json-object-type 'alist 64 | "Type to convert JSON objects to. 65 | Must be one of `alist', `plist', or `hash-table'. Consider let-binding 66 | this around your call to `json-read' instead of `setq'ing it.") 67 | 68 | (defvar json-array-type 'vector 69 | "Type to convert JSON arrays to. 70 | Must be one of `vector' or `list'. Consider let-binding this around 71 | your call to `json-read' instead of `setq'ing it.") 72 | 73 | (defvar json-key-type nil 74 | "Type to convert JSON keys to. 75 | Must be one of `string', `symbol', `keyword', or nil. 76 | 77 | If nil, `json-read' will guess the type based on the value of 78 | `json-object-type': 79 | 80 | If `json-object-type' is: nil will be interpreted as: 81 | `hash-table' `string' 82 | `alist' `symbol' 83 | `plist' `keyword' 84 | 85 | Note that values other than `string' might behave strangely for 86 | Sufficiently Weird keys. Consider let-binding this around your call to 87 | `json-read' instead of `setq'ing it.") 88 | 89 | (defvar json-false :json-false 90 | "Value to use when reading JSON `false'. 91 | If this has the same value as `json-null', you might not be able to tell 92 | the difference between `false' and `null'. Consider let-binding this 93 | around your call to `json-read' instead of `setq'ing it.") 94 | 95 | (defvar json-null nil 96 | "Value to use when reading JSON `null'. 97 | If this has the same value as `json-false', you might not be able to 98 | tell the difference between `false' and `null'. Consider let-binding 99 | this around your call to `json-read' instead of `setq'ing it.") 100 | 101 | 102 | 103 | ;;; Utilities 104 | 105 | (defun json-join (strings separator) 106 | "Join STRINGS with SEPARATOR." 107 | (mapconcat 'identity strings separator)) 108 | 109 | (defun json-alist-p (list) 110 | "Non-null if and only if LIST is an alist." 111 | (or (null list) 112 | (and (consp (car list)) 113 | (json-alist-p (cdr list))))) 114 | 115 | (defun json-plist-p (list) 116 | "Non-null if and only if LIST is a plist." 117 | (or (null list) 118 | (and (keywordp (car list)) 119 | (consp (cdr list)) 120 | (json-plist-p (cddr list))))) 121 | 122 | ;; Reader utilities 123 | 124 | (defsubst json-advance (&optional n) 125 | "Skip past the following N characters." 126 | (forward-char n)) 127 | 128 | (defsubst json-peek () 129 | "Return the character at point." 130 | (let ((char (char-after (point)))) 131 | (or char :json-eof))) 132 | 133 | (defsubst json-pop () 134 | "Advance past the character at point, returning it." 135 | (let ((char (json-peek))) 136 | (if (eq char :json-eof) 137 | (signal 'end-of-file nil) 138 | (json-advance) 139 | char))) 140 | 141 | (defun json-skip-whitespace () 142 | "Skip past the whitespace at point." 143 | (skip-chars-forward "\t\r\n\f\b ")) 144 | 145 | 146 | 147 | ;; Error conditions 148 | 149 | (put 'json-error 'error-message "Unknown JSON error") 150 | (put 'json-error 'error-conditions '(json-error error)) 151 | 152 | (put 'json-readtable-error 'error-message "JSON readtable error") 153 | (put 'json-readtable-error 'error-conditions 154 | '(json-readtable-error json-error error)) 155 | 156 | (put 'json-unknown-keyword 'error-message "Unrecognized keyword") 157 | (put 'json-unknown-keyword 'error-conditions 158 | '(json-unknown-keyword json-error error)) 159 | 160 | (put 'json-number-format 'error-message "Invalid number format") 161 | (put 'json-number-format 'error-conditions 162 | '(json-number-format json-error error)) 163 | 164 | (put 'json-string-escape 'error-message "Bad unicode escape") 165 | (put 'json-string-escape 'error-conditions 166 | '(json-string-escape json-error error)) 167 | 168 | (put 'json-string-format 'error-message "Bad string format") 169 | (put 'json-string-format 'error-conditions 170 | '(json-string-format json-error error)) 171 | 172 | (put 'json-object-format 'error-message "Bad JSON object") 173 | (put 'json-object-format 'error-conditions 174 | '(json-object-format json-error error)) 175 | 176 | 177 | 178 | ;;; Keywords 179 | 180 | (defvar json-keywords '("true" "false" "null") 181 | "List of JSON keywords.") 182 | 183 | ;; Keyword parsing 184 | 185 | (defun json-read-keyword (keyword) 186 | "Read a JSON keyword at point. 187 | KEYWORD is the keyword expected." 188 | (unless (member keyword json-keywords) 189 | (signal 'json-unknown-keyword (list keyword))) 190 | (mapc (lambda (char) 191 | (unless (char-equal char (json-peek)) 192 | (signal 'json-unknown-keyword 193 | (list (save-excursion 194 | (backward-word 1) 195 | (thing-at-point 'word))))) 196 | (json-advance)) 197 | keyword) 198 | (unless (looking-at "\\(\\s-\\|[],}]\\|$\\)") 199 | (signal 'json-unknown-keyword 200 | (list (save-excursion 201 | (backward-word 1) 202 | (thing-at-point 'word))))) 203 | (cond ((string-equal keyword "true") t) 204 | ((string-equal keyword "false") json-false) 205 | ((string-equal keyword "null") json-null))) 206 | 207 | ;; Keyword encoding 208 | 209 | (defun json-encode-keyword (keyword) 210 | "Encode KEYWORD as a JSON value." 211 | (cond ((eq keyword t) "true") 212 | ((eq keyword json-false) "false") 213 | ((eq keyword json-null) "null"))) 214 | 215 | ;;; Numbers 216 | 217 | ;; Number parsing 218 | 219 | (defun json-read-number (&optional sign) 220 | "Read the JSON number following point. 221 | The optional SIGN argument is for internal use. 222 | 223 | N.B.: Only numbers which can fit in Emacs Lisp's native number 224 | representation will be parsed correctly." 225 | ;; If SIGN is non-nil, the number is explicitly signed. 226 | (let ((number-regexp 227 | "\\([0-9]+\\)?\\(\\.[0-9]+\\)?\\([Ee][+-]?[0-9]+\\)?")) 228 | (cond ((and (null sign) (char-equal (json-peek) ?-)) 229 | (json-advance) 230 | (- (json-read-number t))) 231 | ((and (null sign) (char-equal (json-peek) ?+)) 232 | (json-advance) 233 | (json-read-number t)) 234 | ((and (looking-at number-regexp) 235 | (or (match-beginning 1) 236 | (match-beginning 2))) 237 | (goto-char (match-end 0)) 238 | (string-to-number (match-string 0))) 239 | (t (signal 'json-number-format (list (point))))))) 240 | 241 | ;; Number encoding 242 | 243 | (defun json-encode-number (number) 244 | "Return a JSON representation of NUMBER." 245 | (format "%s" number)) 246 | 247 | ;;; Strings 248 | 249 | (defvar json-special-chars 250 | '((?\" . ?\") 251 | (?\\ . ?\\) 252 | (?/ . ?/) 253 | (?b . ?\b) 254 | (?f . ?\f) 255 | (?n . ?\n) 256 | (?r . ?\r) 257 | (?t . ?\t)) 258 | "Characters which are escaped in JSON, with their elisp counterparts.") 259 | 260 | ;; String parsing 261 | 262 | (defun json-read-escaped-char () 263 | "Read the JSON string escaped character at point." 264 | ;; Skip over the '\' 265 | (json-advance) 266 | (let* ((char (json-pop)) 267 | (special (assq char json-special-chars))) 268 | (cond 269 | (special (cdr special)) 270 | ((not (eq char ?u)) char) 271 | ((looking-at "[0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f][0-9A-Fa-f]") 272 | (let ((hex (match-string 0))) 273 | (json-advance 4) 274 | (json-decode-char0 'ucs (string-to-number hex 16)))) 275 | (t 276 | (signal 'json-string-escape (list (point))))))) 277 | 278 | (defun json-read-string () 279 | "Read the JSON string at point." 280 | (unless (char-equal (json-peek) ?\") 281 | (signal 'json-string-format (list "doesn't start with '\"'!"))) 282 | ;; Skip over the '"' 283 | (json-advance) 284 | (let ((characters '()) 285 | (char (json-peek))) 286 | (while (not (char-equal char ?\")) 287 | (push (if (char-equal char ?\\) 288 | (json-read-escaped-char) 289 | (json-pop)) 290 | characters) 291 | (setq char (json-peek))) 292 | ;; Skip over the '"' 293 | (json-advance) 294 | (if characters 295 | (apply 'string (nreverse characters)) 296 | ""))) 297 | 298 | ;; String encoding 299 | 300 | (defun json-encode-char (char) 301 | "Encode CHAR as a JSON string." 302 | (setq char (json-encode-char0 char 'ucs)) 303 | (let ((control-char (car (rassoc char json-special-chars)))) 304 | (cond 305 | ;; Special JSON character (\n, \r, etc.) 306 | (control-char 307 | (format "\\%c" control-char)) 308 | ;; ASCIIish printable character 309 | ((and (> char 31) (< char 161)) 310 | (format "%c" char)) 311 | ;; Fallback: UCS code point in \uNNNN form 312 | (t 313 | (format "\\u%04x" char))))) 314 | 315 | (defun json-encode-string (string) 316 | "Return a JSON representation of STRING." 317 | (format "\"%s\"" (mapconcat 'json-encode-char string ""))) 318 | 319 | ;;; JSON Objects 320 | 321 | (defun json-new-object () 322 | "Create a new Elisp object corresponding to a JSON object. 323 | Please see the documentation of `json-object-type'." 324 | (cond ((eq json-object-type 'hash-table) 325 | (make-hash-table :test 'equal)) 326 | (t 327 | (list)))) 328 | 329 | (defun json-add-to-object (object key value) 330 | "Add a new KEY -> VALUE association to OBJECT. 331 | Returns the updated object, which you should save, e.g.: 332 | (setq obj (json-add-to-object obj \"foo\" \"bar\")) 333 | Please see the documentation of `json-object-type' and `json-key-type'." 334 | (let ((json-key-type 335 | (if (eq json-key-type nil) 336 | (cdr (assq json-object-type '((hash-table . string) 337 | (alist . symbol) 338 | (plist . keyword)))) 339 | json-key-type))) 340 | (setq key 341 | (cond ((eq json-key-type 'string) 342 | key) 343 | ((eq json-key-type 'symbol) 344 | (intern key)) 345 | ((eq json-key-type 'keyword) 346 | (intern (concat ":" key))))) 347 | (cond ((eq json-object-type 'hash-table) 348 | (puthash key value object) 349 | object) 350 | ((eq json-object-type 'alist) 351 | (cons (cons key value) object)) 352 | ((eq json-object-type 'plist) 353 | (cons key (cons value object)))))) 354 | 355 | ;; JSON object parsing 356 | 357 | (defun json-read-object () 358 | "Read the JSON object at point." 359 | ;; Skip over the "{" 360 | (json-advance) 361 | (json-skip-whitespace) 362 | ;; read key/value pairs until "}" 363 | (let ((elements (json-new-object)) 364 | key value) 365 | (while (not (char-equal (json-peek) ?})) 366 | (json-skip-whitespace) 367 | (setq key (json-read-string)) 368 | (json-skip-whitespace) 369 | (if (char-equal (json-peek) ?:) 370 | (json-advance) 371 | (signal 'json-object-format (list ":" (json-peek)))) 372 | (setq value (json-read)) 373 | (setq elements (json-add-to-object elements key value)) 374 | (json-skip-whitespace) 375 | (unless (char-equal (json-peek) ?}) 376 | (if (char-equal (json-peek) ?,) 377 | (json-advance) 378 | (signal 'json-object-format (list "," (json-peek)))))) 379 | ;; Skip over the "}" 380 | (json-advance) 381 | elements)) 382 | 383 | ;; Hash table encoding 384 | 385 | (defun json-encode-hash-table (hash-table) 386 | "Return a JSON representation of HASH-TABLE." 387 | (format "{%s}" 388 | (json-join 389 | (let (r) 390 | (maphash 391 | (lambda (k v) 392 | (push (format "%s:%s" 393 | (json-encode k) 394 | (json-encode v)) 395 | r)) 396 | hash-table) 397 | r) 398 | ", "))) 399 | 400 | ;; List encoding (including alists and plists) 401 | 402 | (defun json-encode-alist (alist) 403 | "Return a JSON representation of ALIST." 404 | (format "{%s}" 405 | (json-join (mapcar (lambda (cons) 406 | (format "%s:%s" 407 | (json-encode (car cons)) 408 | (json-encode (cdr cons)))) 409 | alist) 410 | ", "))) 411 | 412 | (defun json-encode-plist (plist) 413 | "Return a JSON representation of PLIST." 414 | (let (result) 415 | (while plist 416 | (push (concat (json-encode (car plist)) 417 | ":" 418 | (json-encode (cadr plist))) 419 | result) 420 | (setq plist (cddr plist))) 421 | (concat "{" (json-join (nreverse result) ", ") "}"))) 422 | 423 | (defun json-encode-list (list) 424 | "Return a JSON representation of LIST. 425 | Tries to DWIM: simple lists become JSON arrays, while alists and plists 426 | become JSON objects." 427 | (cond ((null list) "null") 428 | ((json-alist-p list) (json-encode-alist list)) 429 | ((json-plist-p list) (json-encode-plist list)) 430 | ((listp list) (json-encode-array list)) 431 | (t 432 | (signal 'json-error (list list))))) 433 | 434 | ;;; Arrays 435 | 436 | ;; Array parsing 437 | 438 | (defun json-read-array () 439 | "Read the JSON array at point." 440 | ;; Skip over the "[" 441 | (json-advance) 442 | (json-skip-whitespace) 443 | ;; read values until "]" 444 | (let (elements) 445 | (while (not (char-equal (json-peek) ?\])) 446 | (push (json-read) elements) 447 | (json-skip-whitespace) 448 | (unless (char-equal (json-peek) ?\]) 449 | (if (char-equal (json-peek) ?,) 450 | (json-advance) 451 | (signal 'json-error (list 'bleah))))) 452 | ;; Skip over the "]" 453 | (json-advance) 454 | (apply json-array-type (nreverse elements)))) 455 | 456 | ;; Array encoding 457 | 458 | (defun json-encode-array (array) 459 | "Return a JSON representation of ARRAY." 460 | (concat "[" (mapconcat 'json-encode array ", ") "]")) 461 | 462 | 463 | 464 | ;;; JSON reader. 465 | 466 | (defvar json-readtable 467 | (let ((table 468 | '((?t json-read-keyword "true") 469 | (?f json-read-keyword "false") 470 | (?n json-read-keyword "null") 471 | (?{ json-read-object) 472 | (?\[ json-read-array) 473 | (?\" json-read-string)))) 474 | (mapc (lambda (char) 475 | (push (list char 'json-read-number) table)) 476 | '(?- ?+ ?. ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) 477 | table) 478 | "Readtable for JSON reader.") 479 | 480 | (defun json-read () 481 | "Parse and return the JSON object following point. 482 | Advances point just past JSON object." 483 | (json-skip-whitespace) 484 | (let ((char (json-peek))) 485 | (if (not (eq char :json-eof)) 486 | (let ((record (cdr (assq char json-readtable)))) 487 | (if (functionp (car record)) 488 | (apply (car record) (cdr record)) 489 | (signal 'json-readtable-error record))) 490 | (signal 'end-of-file nil)))) 491 | 492 | ;; Syntactic sugar for the reader 493 | 494 | (defun json-read-from-string (string) 495 | "Read the JSON object contained in STRING and return it." 496 | (with-temp-buffer 497 | (insert string) 498 | (goto-char (point-min)) 499 | (json-read))) 500 | 501 | (defun json-read-file (file) 502 | "Read the first JSON object contained in FILE and return it." 503 | (with-temp-buffer 504 | (insert-file-contents file) 505 | (goto-char (point-min)) 506 | (json-read))) 507 | 508 | 509 | 510 | ;;; JSON encoder 511 | 512 | (defun json-encode (object) 513 | "Return a JSON representation of OBJECT as a string." 514 | (cond ((memq object (list t json-null json-false)) 515 | (json-encode-keyword object)) 516 | ((stringp object) (json-encode-string object)) 517 | ((keywordp object) (json-encode-string 518 | (substring (symbol-name object) 1))) 519 | ((symbolp object) (json-encode-string 520 | (symbol-name object))) 521 | ((numberp object) (json-encode-number object)) 522 | ((arrayp object) (json-encode-array object)) 523 | ((hash-table-p object) (json-encode-hash-table object)) 524 | ((listp object) (json-encode-list object)) 525 | (t (signal 'json-error (list object))))) 526 | 527 | (provide 'json) 528 | 529 | ;; arch-tag: 15f6e4c8-b831-4172-8749-bbc680c50ea1 530 | ;;; json.el ends here 531 | -------------------------------------------------------------------------------- /modes/agda2/agda-input.el: -------------------------------------------------------------------------------- 1 | ;;; agda-input.el --- The Agda input method 2 | 3 | ;;; Commentary: 4 | 5 | ;; A highly customisable input method which can inherit from other 6 | ;; Quail input methods. By default the input method is geared towards 7 | ;; the input of mathematical and other symbols in Agda programs. 8 | ;; 9 | ;; Use M-x customize-group agda-input to customise this input method. 10 | ;; Note that the functions defined under "Functions used to tweak 11 | ;; translation pairs" below can be used to tweak both the key 12 | ;; translations inherited from other input methods as well as the 13 | ;; ones added specifically for this one. 14 | ;; 15 | ;; Use agda-input-show-translations to see all the characters which 16 | ;; can be typed using this input method (except for those 17 | ;; corresponding to ASCII characters). 18 | 19 | ;;; Code: 20 | 21 | (require 'quail) 22 | (require 'cl) 23 | 24 | ;; Quail is quite stateful, so be careful when editing this code. Note 25 | ;; that with-temp-buffer is used below whenever buffer-local state is 26 | ;; modified. 27 | 28 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 29 | ;; Utility functions 30 | 31 | (defun agda-input-concat-map (f xs) 32 | "Concat (map F XS)." 33 | (apply 'append (mapcar f xs))) 34 | 35 | (defun agda-input-to-string-list (s) 36 | "Convert a string S to a list of one-character strings, after 37 | removing all space and newline characters." 38 | (agda-input-concat-map 39 | (lambda (c) (if (member c (string-to-list " \n")) 40 | nil 41 | (list (string c)))) 42 | (string-to-list s))) 43 | 44 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 45 | ;; Functions used to tweak translation pairs 46 | 47 | ;; lexical-let is used since Elisp lacks lexical scoping. 48 | 49 | (defun agda-input-compose (f g) 50 | "\x -> concatMap F (G x)" 51 | (lexical-let ((f1 f) (g1 g)) 52 | (lambda (x) (agda-input-concat-map f1 (funcall g1 x))))) 53 | 54 | (defun agda-input-or (f g) 55 | "\x -> F x ++ G x" 56 | (lexical-let ((f1 f) (g1 g)) 57 | (lambda (x) (append (funcall f1 x) (funcall g1 x))))) 58 | 59 | (defun agda-input-nonempty () 60 | "Only keep pairs with a non-empty first component." 61 | (lambda (x) (if (> (length (car x)) 0) (list x)))) 62 | 63 | (defun agda-input-prepend (prefix) 64 | "Prepend PREFIX to all key sequences." 65 | (lexical-let ((prefix1 prefix)) 66 | (lambda (x) `((,(concat prefix1 (car x)) . ,(cdr x)))))) 67 | 68 | (defun agda-input-prefix (prefix) 69 | "Only keep pairs whose key sequence starts with PREFIX." 70 | (lexical-let ((prefix1 prefix)) 71 | (lambda (x) 72 | (if (equal (substring (car x) 0 (length prefix1)) prefix1) 73 | (list x))))) 74 | 75 | (defun agda-input-suffix (suffix) 76 | "Only keep pairs whose key sequence ends with SUFFIX." 77 | (lexical-let ((suffix1 suffix)) 78 | (lambda (x) 79 | (if (equal (substring (car x) 80 | (- (length (car x)) (length suffix1))) 81 | suffix1) 82 | (list x))))) 83 | 84 | (defun agda-input-drop (ss) 85 | "Drop pairs matching one of the given key sequences. 86 | SS should be a list of strings." 87 | (lexical-let ((ss1 ss)) 88 | (lambda (x) (unless (member (car x) ss1) (list x))))) 89 | 90 | (defun agda-input-drop-beginning (n) 91 | "Drop N characters from the beginning of each key sequence." 92 | (lexical-let ((n1 n)) 93 | (lambda (x) `((,(substring (car x) n1) . ,(cdr x)))))) 94 | 95 | (defun agda-input-drop-end (n) 96 | "Drop N characters from the end of each key sequence." 97 | (lexical-let ((n1 n)) 98 | (lambda (x) 99 | `((,(substring (car x) 0 (- (length (car x)) n1)) . 100 | ,(cdr x)))))) 101 | 102 | (defun agda-input-drop-prefix (prefix) 103 | "Only keep pairs whose key sequence starts with PREFIX. 104 | This prefix is dropped." 105 | (agda-input-compose 106 | (agda-input-drop-beginning (length prefix)) 107 | (agda-input-prefix prefix))) 108 | 109 | (defun agda-input-drop-suffix (suffix) 110 | "Only keep pairs whose key sequence ends with SUFFIX. 111 | This suffix is dropped." 112 | (lexical-let ((suffix1 suffix)) 113 | (agda-input-compose 114 | (agda-input-drop-end (length suffix1)) 115 | (agda-input-suffix suffix1)))) 116 | 117 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 118 | ;; Customization 119 | 120 | ;; The :set keyword is set to 'agda-input-incorporate-changed-setting 121 | ;; so that the input method gets updated immediately when users 122 | ;; customize it. However, the setup functions cannot be run before all 123 | ;; variables have been defined. Hence the :initialize keyword is set to 124 | ;; 'custom-initialize-default to ensure that the setup is not performed 125 | ;; until agda-input-setup is called at the end of this file. 126 | 127 | (defgroup agda-input nil 128 | "The Agda 2 input method. 129 | After tweaking these settings you may want to inspect the resulting 130 | translations using `agda-input-show-translations'." 131 | :group 'agda2 132 | :group 'leim) 133 | 134 | (defcustom agda-input-tweak-all 135 | '(agda-input-compose 136 | (agda-input-prepend "\\") 137 | (agda-input-nonempty)) 138 | "An expression yielding a function which can be used to tweak 139 | all translations before they are included in the input method. 140 | The resulting function (if non-nil) is applied to every 141 | \(KEY-SEQUENCE . TRANSLATION) pair and should return a list of such 142 | pairs. (Note that the translations can be anything accepted by 143 | `quail-defrule'.) 144 | 145 | If you change this setting manually (without using the 146 | customization buffer) you need to call `agda-input-setup' in 147 | order for the change to take effect." 148 | :group 'agda-input 149 | :set 'agda-input-incorporate-changed-setting 150 | :initialize 'custom-initialize-default 151 | :type 'sexp) 152 | 153 | (defcustom agda-input-inherit 154 | `(("TeX" . (agda-input-compose 155 | (agda-input-drop '("geq" "leq" "bullet" "qed")) 156 | (agda-input-or 157 | (agda-input-drop-prefix "\\") 158 | (agda-input-or 159 | (agda-input-compose 160 | (agda-input-drop '("^o")) 161 | (agda-input-prefix "^")) 162 | (agda-input-prefix "_"))))) 163 | ) 164 | "A list of Quail input methods whose translations should be 165 | inherited by the Agda input method (with the exception of 166 | translations corresponding to ASCII characters). 167 | 168 | The list consists of pairs (qp . tweak), where qp is the name of 169 | a Quail package, and tweak is an expression of the same kind as 170 | `agda-input-tweak-all' which is used to tweak the translation 171 | pairs of the input method. 172 | 173 | If you change this setting manually (without using the 174 | customization buffer) you need to call `agda-input-setup' in 175 | order for the change to take effect." 176 | :group 'agda-input 177 | :set 'agda-input-incorporate-changed-setting 178 | :initialize 'custom-initialize-default 179 | :type '(repeat (cons (string :tag "Quail package") 180 | (sexp :tag "Tweaking function")))) 181 | 182 | (defcustom agda-input-translations 183 | (let ((max-lisp-eval-depth 2800)) `( 184 | 185 | ;; Equality and similar symbols. 186 | 187 | ("eq" . ,(agda-input-to-string-list "=∼∽≈≋∻∾∿≀≃⋍≂≅ ≌≊≡≣≐≑≒≓≔≕≖≗≘≙≚≛≜≝≞≟≍≎≏≬⋕")) 188 | ("eqn" . ,(agda-input-to-string-list "≠≁ ≉ ≄ ≇≆ ≢ ≭ ")) 189 | 190 | ("=n" . ("≠")) 191 | ("~" . ("∼")) ("~n" . ("≁")) 192 | ("~~" . ("≈")) ("~~n" . ("≉")) 193 | ("~~~" . ("≋")) 194 | (":~" . ("∻")) 195 | ("~-" . ("≃")) ("~-n" . ("≄")) 196 | ("-~" . ("≂")) 197 | ("~=" . ("≅")) ("~=n" . ("≇")) 198 | ("~~-" . ("≊")) 199 | ("==" . ("≡")) ("==n" . ("≢")) 200 | ("===" . ("≣")) 201 | (".=" . ("≐")) (".=." . ("≑")) 202 | (":=" . ("≔")) ("=:" . ("≕")) 203 | ("=o" . ("≗")) 204 | ("(=" . ("≘")) 205 | ("and=" . ("≙")) ("or=" . ("≚")) 206 | ("*=" . ("≛")) 207 | ("t=" . ("≜")) 208 | ("def=" . ("≝")) 209 | ("m=" . ("≞")) 210 | ("?=" . ("≟")) 211 | 212 | ;; Inequality and similar symbols. 213 | 214 | ("leq" . ,(agda-input-to-string-list "<≪⋘≤≦≲ ≶≺≼≾⊂⊆ ⋐⊏⊑ ⊰⊲⊴⋖⋚⋜⋞")) 215 | ("leqn" . ,(agda-input-to-string-list "≮ ≰≨≴⋦≸⊀ ⋨⊄⊈⊊ ⋢⋤ ⋪⋬ ⋠")) 216 | ("geq" . ,(agda-input-to-string-list ">≫⋙≥≧≳ ≷≻≽≿⊃⊇ ⋑⊐⊒ ⊱⊳⊵⋗⋛⋝⋟")) 217 | ("geqn" . ,(agda-input-to-string-list "≯ ≱≩≵⋧≹⊁ ⋩⊅⊉⊋ ⋣⋥ ⋫⋭ ⋡")) 218 | 219 | ("<=" . ("≤")) (">=" . ("≥")) 220 | ("<=n" . ("≰")) (">=n" . ("≱")) 221 | ("len" . ("≰")) ("gen" . ("≱")) 222 | ("n" . ("≯")) 223 | ("<~" . ("≲")) (">~" . ("≳")) 224 | ("<~n" . ("⋦")) (">~n" . ("⋧")) 225 | ("<~nn" . ("≴")) (">~nn" . ("≵")) 226 | 227 | ("sub" . ("⊂")) ("sup" . ("⊃")) 228 | ("subn" . ("⊄")) ("supn" . ("⊅")) 229 | ("sub=" . ("⊆")) ("sup=" . ("⊇")) 230 | ("sub=n" . ("⊈")) ("sup=n" . ("⊉")) 231 | 232 | ("squb" . ("⊏")) ("squp" . ("⊐")) 233 | ("squb=" . ("⊑")) ("squp=" . ("⊒")) 234 | ("squb=n" . ("⋢")) ("squp=n" . ("⋣")) 235 | 236 | ;; Set membership etc. 237 | 238 | ("member" . ,(agda-input-to-string-list "∈∉∊∋∌∍⋲⋳⋴⋵⋶⋷⋸⋹⋺⋻⋼⋽⋾⋿")) 239 | 240 | ("inn" . ("∉")) 241 | ("nin" . ("∌")) 242 | 243 | ;; Intersections, unions etc. 244 | 245 | ("intersection" . ,(agda-input-to-string-list "∩⋂∧⋀⋏⨇⊓⨅⋒∏ ⊼ ⨉")) 246 | ("union" . ,(agda-input-to-string-list "∪⋃∨⋁⋎⨈⊔⨆⋓∐⨿⊽⊻⊍⨃⊎⨄⊌∑⅀")) 247 | 248 | ("and" . ("∧")) ("or" . ("∨")) 249 | ("And" . ("⋀")) ("Or" . ("⋁")) 250 | ("i" . ("∩")) ("un" . ("∪")) ("u+" . ("⊎")) ("u." . ("⊍")) 251 | ("I" . ("⋂")) ("Un" . ("⋃")) ("U+" . ("⨄")) ("U." . ("⨃")) 252 | ("glb" . ("⊓")) ("lub" . ("⊔")) 253 | ("Glb" . ("⨅")) ("Lub" . ("⨆")) 254 | 255 | ;; Entailment etc. 256 | 257 | ("entails" . ,(agda-input-to-string-list "⊢⊣⊤⊥⊦⊧⊨⊩⊪⊫⊬⊭⊮⊯")) 258 | 259 | ("|-" . ("⊢")) ("|-n" . ("⊬")) 260 | ("-|" . ("⊣")) 261 | ("|=" . ("⊨")) ("|=n" . ("⊭")) 262 | 263 | ;; Divisibility, parallelity. 264 | 265 | ("|" . ("∣")) ("|n" . ("∤")) 266 | ("||" . ("∥")) ("||n" . ("∦")) 267 | 268 | ;; Some symbols from logic and set theory. 269 | 270 | ("all" . ("∀")) 271 | ("ex" . ("∃")) 272 | ("exn" . ("∄")) 273 | ("0" . ("∅")) 274 | ("C" . ("∁")) 275 | 276 | ;; Corners, ceilings and floors. 277 | 278 | ("c" . ,(agda-input-to-string-list "⌜⌝⌞⌟⌈⌉⌊⌋")) 279 | ("cu" . ,(agda-input-to-string-list "⌜⌝ ⌈⌉ ")) 280 | ("cl" . ,(agda-input-to-string-list " ⌞⌟ ⌊⌋")) 281 | 282 | ("cul" . ("⌜")) ("cuL" . ("⌈")) 283 | ("cur" . ("⌝")) ("cuR" . ("⌉")) 284 | ("cll" . ("⌞")) ("clL" . ("⌊")) 285 | ("clr" . ("⌟")) ("clR" . ("⌋")) 286 | 287 | ;; Various operators/symbols. 288 | 289 | ,@(if (>= emacs-major-version 23) 290 | '(("pm" . ("±")) 291 | ("cdot" . ("·")) 292 | ("times" . ("×")) 293 | ("div" . ("÷")) 294 | ("neg" . ("¬")))) 295 | 296 | ("qed" . ("∎")) 297 | ("x" . ("×")) 298 | ("o" . ("∘")) 299 | ("comp" . ("∘")) 300 | ("." . ("∙")) 301 | ("*" . ("⋆")) 302 | (".+" . ("∔")) 303 | (".-" . ("∸")) 304 | (":" . ("∶")) 305 | ("::" . ("∷")) 306 | ("::-" . ("∺")) 307 | ("-:" . ("∹")) 308 | ("+ " . ("⊹")) 309 | ("surd3" . ("∛")) 310 | ("surd4" . ("∜")) 311 | ("increment" . ("∆")) 312 | ("inf" . ("∞")) 313 | 314 | ;; Circled operators. 315 | 316 | ("o+" . ("⊕")) 317 | ("o--" . ("⊖")) 318 | ("ox" . ("⊗")) 319 | ("o/" . ("⊘")) 320 | ("o." . ("⊙")) 321 | ("oo" . ("⊚")) 322 | ("o*" . ("⊛")) 323 | ("o=" . ("⊜")) 324 | ("o-" . ("⊝")) 325 | 326 | ("O+" . ("⨁")) 327 | ("Ox" . ("⨂")) 328 | ("O." . ("⨀")) 329 | ("O*" . ("⍟")) 330 | 331 | ;; Boxed operators. 332 | 333 | ("b+" . ("⊞")) 334 | ("b-" . ("⊟")) 335 | ("bx" . ("⊠")) 336 | ("b." . ("⊡")) 337 | 338 | ;; Various symbols. 339 | 340 | ("integral" . ,(agda-input-to-string-list "∫∬∭∮∯∰∱∲∳")) 341 | ("angle" . ,(agda-input-to-string-list "∟∡∢⊾⊿")) 342 | ("join" . ,(agda-input-to-string-list "⋈⋉⋊⋋⋌⨝⟕⟖⟗")) 343 | 344 | ;; Arrows. 345 | 346 | ("l" . ,(agda-input-to-string-list "←⇐⇚⇇⇆↤⇦↞↼↽⇠⇺↜⇽⟵⟸↚⇍⇷ ↹ ↢↩↫⇋⇜⇤⟻⟽⤆↶↺⟲ ")) 347 | ("r" . ,(agda-input-to-string-list "→⇒⇛⇉⇄↦⇨↠⇀⇁⇢⇻↝⇾⟶⟹↛⇏⇸⇶ ↴ ↣↪↬⇌⇝⇥⟼⟾⤇↷↻⟳⇰⇴⟴⟿ ➵➸➙➔➛➜➝➞➟➠➡➢➣➤➧➨➩➪➫➬➭➮➯➱➲➳➺➻➼➽➾")) 348 | ("u" . ,(agda-input-to-string-list "↑⇑⟰⇈⇅↥⇧↟↿↾⇡⇞ ↰↱➦ ⇪⇫⇬⇭⇮⇯ ")) 349 | ("d" . ,(agda-input-to-string-list "↓⇓⟱⇊⇵↧⇩↡⇃⇂⇣⇟ ↵↲↳➥ ↯ ")) 350 | ("ud" . ,(agda-input-to-string-list "↕⇕ ↨⇳ ")) 351 | ("lr" . ,(agda-input-to-string-list "↔⇔ ⇼↭⇿⟷⟺↮⇎⇹ ")) 352 | ("ul" . ,(agda-input-to-string-list "↖⇖ ⇱↸ ")) 353 | ("ur" . ,(agda-input-to-string-list "↗⇗ ➶➹➚ ")) 354 | ("dr" . ,(agda-input-to-string-list "↘⇘ ⇲ ➴➷➘ ")) 355 | ("dl" . ,(agda-input-to-string-list "↙⇙ ")) 356 | 357 | ("l-" . ("←")) ("<-" . ("←")) ("l=" . ("⇐")) 358 | ("r-" . ("→")) ("->" . ("→")) ("r=" . ("⇒")) ("=>" . ("⇒")) 359 | ("u-" . ("↑")) ("u=" . ("⇑")) 360 | ("d-" . ("↓")) ("d=" . ("⇓")) 361 | ("ud-" . ("↕")) ("ud=" . ("⇕")) 362 | ("lr-" . ("↔")) ("<->" . ("↔")) ("lr=" . ("⇔")) ("<=>" . ("⇔")) 363 | ("ul-" . ("↖")) ("ul=" . ("⇖")) 364 | ("ur-" . ("↗")) ("ur=" . ("⇗")) 365 | ("dr-" . ("↘")) ("dr=" . ("⇘")) 366 | ("dl-" . ("↙")) ("dl=" . ("⇙")) 367 | 368 | ("l==" . ("⇚")) ("l-2" . ("⇇")) ("l-r-" . ("⇆")) 369 | ("r==" . ("⇛")) ("r-2" . ("⇉")) ("r-3" . ("⇶")) ("r-l-" . ("⇄")) 370 | ("u==" . ("⟰")) ("u-2" . ("⇈")) ("u-d-" . ("⇅")) 371 | ("d==" . ("⟱")) ("d-2" . ("⇊")) ("d-u-" . ("⇵")) 372 | 373 | ("l--" . ("⟵")) ("<--" . ("⟵")) ("l~" . ("↜" "⇜")) 374 | ("r--" . ("⟶")) ("-->" . ("⟶")) ("r~" . ("↝" "⇝" "⟿")) 375 | ("lr--" . ("⟷")) ("<-->" . ("⟷")) ("lr~" . ("↭")) 376 | 377 | ("l-n" . ("↚")) ("<-n" . ("↚")) ("l=n" . ("⇍")) 378 | ("r-n" . ("↛")) ("->n" . ("↛")) ("r=n" . ("⇏")) ("=>n" . ("⇏")) 379 | ("lr-n" . ("↮")) ("<->n" . ("↮")) ("lr=n" . ("⇎")) ("<=>n" . ("⇎")) 380 | 381 | ("l-|" . ("↤")) ("ll-" . ("↞")) 382 | ("r-|" . ("↦")) ("rr-" . ("↠")) 383 | ("u-|" . ("↥")) ("uu-" . ("↟")) 384 | ("d-|" . ("↧")) ("dd-" . ("↡")) 385 | ("ud-|" . ("↨")) 386 | 387 | ("dz" . ("↯")) 388 | 389 | ;; Ellipsis. 390 | 391 | ("..." . ,(agda-input-to-string-list "⋯⋮⋰⋱")) 392 | 393 | ;; Box-drawing characters. 394 | 395 | ("---" . ,(agda-input-to-string-list "─│┌┐└┘├┤┬┼┴╴╵╶╷╭╮╯╰╱╲╳")) 396 | ("--=" . ,(agda-input-to-string-list "═║╔╗╚╝╠╣╦╬╩ ╒╕╘╛╞╡╤╪╧ ╓╖╙╜╟╢╥╫╨")) 397 | ("--_" . ,(agda-input-to-string-list "━┃┏┓┗┛┣┫┳╋┻╸╹╺╻ 398 | ┍┯┑┕┷┙┝┿┥┎┰┒┖┸┚┠╂┨┞╀┦┟╁┧┢╈┪┡╇┩ 399 | ┮┭┶┵┾┽┲┱┺┹╊╉╆╅╄╃ ╿╽╼╾")) 400 | ("--." . ,(agda-input-to-string-list "╌╎┄┆┈┊ 401 | ╍╏┅┇┉┋")) 402 | 403 | ;; Triangles. 404 | 405 | ;; Big/small, black/white. 406 | 407 | ("t" . ,(agda-input-to-string-list "◂◃◄◅▸▹►▻▴▵▾▿◢◿◣◺◤◸◥◹")) 408 | ("T" . ,(agda-input-to-string-list "◀◁▶▷▲△▼▽◬◭◮")) 409 | 410 | ("tb" . ,(agda-input-to-string-list "◂▸▴▾◄►◢◣◤◥")) 411 | ("tw" . ,(agda-input-to-string-list "◃▹▵▿◅▻◿◺◸◹")) 412 | 413 | ("Tb" . ,(agda-input-to-string-list "◀▶▲▼")) 414 | ("Tw" . ,(agda-input-to-string-list "◁▷△▽")) 415 | 416 | ;; Squares. 417 | 418 | ("sq" . ,(agda-input-to-string-list "■□◼◻◾◽▣▢▤▥▦▧▨▩◧◨◩◪◫◰◱◲◳")) 419 | ("sqb" . ,(agda-input-to-string-list "■◼◾")) 420 | ("sqw" . ,(agda-input-to-string-list "□◻◽")) 421 | ("sq." . ("▣")) 422 | ("sqo" . ("▢")) 423 | 424 | ;; Rectangles. 425 | 426 | ("re" . ,(agda-input-to-string-list "▬▭▮▯")) 427 | ("reb" . ,(agda-input-to-string-list "▬▮")) 428 | ("rew" . ,(agda-input-to-string-list "▭▯")) 429 | 430 | ;; Parallelograms. 431 | 432 | ("pa" . ,(agda-input-to-string-list "▰▱")) 433 | ("pab" . ("▰")) 434 | ("paw" . ("▱")) 435 | 436 | ;; Diamonds. 437 | 438 | ("di" . ,(agda-input-to-string-list "◆◇◈")) 439 | ("dib" . ("◆")) 440 | ("diw" . ("◇")) 441 | ("di." . ("◈")) 442 | 443 | ;; Circles. 444 | 445 | ("ci" . ,(agda-input-to-string-list "●○◎◌◯◍◐◑◒◓◔◕◖◗◠◡◴◵◶◷⚆⚇⚈⚉")) 446 | ("cib" . ("●")) 447 | ("ciw" . ("○")) 448 | ("ci." . ("◎")) 449 | ("ci.." . ("◌")) 450 | ("ciO" . ("◯")) 451 | 452 | ;; Stars. 453 | 454 | ("st" . ,(agda-input-to-string-list "⋆✦✧✶✴✹ ★☆✪✫✯✰✵✷✸")) 455 | ("st4" . ,(agda-input-to-string-list "✦✧")) 456 | ("st6" . ("✶")) 457 | ("st8" . ("✴")) 458 | ("st12" . ("✹")) 459 | 460 | ;; Blackboard bold letters. 461 | 462 | ("bn" . ("ℕ")) 463 | ("bz" . ("ℤ")) 464 | ("bq" . ("ℚ")) 465 | ("br" . ("ℝ")) 466 | ("bc" . ("ℂ")) 467 | ("bp" . ("ℙ")) 468 | ("bsum" . ("⅀")) 469 | 470 | ;; Parentheses. 471 | 472 | ("(" . ,(agda-input-to-string-list "([{⁅⁽₍〈⎴⟦⟨⟪〈《「『【〔〖〚︵︷︹︻︽︿﹁﹃﹙﹛﹝（［｛｢")) 473 | (")" . ,(agda-input-to-string-list ")]}⁆⁾₎〉⎵⟧⟩⟫〉》」』】〕〗〛︶︸︺︼︾﹀﹂﹄﹚﹜﹞）］｝｣")) 474 | 475 | ("[[" . ("⟦")) 476 | ("]]" . ("⟧")) 477 | ("<" . ("⟨")) 478 | (">" . ("⟩")) 479 | ("<<" . ("⟪")) 480 | (">>" . ("⟫")) 481 | 482 | ;; Primes. 483 | 484 | ("'" . ,(agda-input-to-string-list "′″‴⁗")) 485 | ("`" . ,(agda-input-to-string-list "‵‶‷")) 486 | 487 | ;; Fractions. 488 | 489 | ("frac" . ,(agda-input-to-string-list "¼½¾⅓⅔⅕⅖⅗⅘⅙⅚⅛⅜⅝⅞⅟")) 490 | 491 | ;; Bullets. 492 | 493 | ("bu" . ,(agda-input-to-string-list "•◦‣⁌⁍")) 494 | ("bub" . ("•")) 495 | ("buw" . ("◦")) 496 | ("but" . ("‣")) 497 | 498 | ;; Musical symbols. 499 | 500 | ("note" . ,(agda-input-to-string-list "♩♪♫♬")) 501 | ("b" . ("♭")) 502 | ("#" . ("♯")) 503 | 504 | ;; Other punctuation and symbols. 505 | 506 | ("\\" . ("\\")) 507 | ("en" . ("–")) 508 | ("em" . ("—")) 509 | ("^i" . ("ⁱ")) 510 | ("!!" . ("‼")) 511 | ("??" . ("⁇")) 512 | ("?!" . ("‽" "⁈")) 513 | ("!?" . ("⁉")) 514 | ("die" . ,(agda-input-to-string-list "⚀⚁⚂⚃⚄⚅")) 515 | ("asterisk" . ,(agda-input-to-string-list "⁎⁑⁂✢✣✤✥✱✲✳✺✻✼✽❃❉❊❋")) 516 | ("8<" . ("✂" "✄")) 517 | ("tie" . ("⁀")) 518 | ("undertie" . ("‿")) 519 | ("apl" . ,(agda-input-to-string-list "⌶⌷⌸⌹⌺⌻⌼⌽⌾⌿⍀⍁⍂⍃⍄⍅⍆⍇⍈ 520 | ⍉⍊⍋⍌⍍⍎⍏⍐⍑⍒⍓⍔⍕⍖⍗⍘⍙⍚⍛ 521 | ⍜⍝⍞⍟⍠⍡⍢⍣⍤⍥⍦⍧⍨⍩⍪⍫⍬⍭⍮ 522 | ⍯⍰⍱⍲⍳⍴⍵⍶⍷⍸⍹⍺⎕")) 523 | 524 | ;; Shorter forms of many greek letters. 525 | 526 | ("Ga" . ("α")) ("GA" . ("Α")) 527 | ("Gb" . ("β")) ("GB" . ("Β")) 528 | ("Gg" . ("γ")) ("GG" . ("Γ")) 529 | ("Gd" . ("δ")) ("GD" . ("Δ")) 530 | ("Ge" . ("ε")) ("GE" . ("Ε")) 531 | ("Gz" . ("ζ")) ("GZ" . ("Ζ")) 532 | ;; \eta \Eta 533 | ("Gth" . ("θ")) ("GTH" . ("θ")) 534 | ("Gi" . ("ι")) ("GI" . ("Ι")) 535 | ("Gk" . ("κ")) ("GK" . ("Κ")) 536 | ("Gl" . ("λ")) ("GL" . ("Λ")) 537 | ("Gm" . ("μ")) ("GM" . ("Μ")) 538 | ("Gn" . ("ν")) ("GN" . ("Ν")) 539 | ("Gx" . ("ξ")) ("GX" . ("Ξ")) 540 | ;; \omicron \Omicron 541 | ;; \pi \Pi 542 | ("Gr" . ("ρ")) ("GR" . ("Ρ")) 543 | ("Gs" . ("σ")) ("GS" . ("Σ")) 544 | ("Gt" . ("τ")) ("GT" . ("Τ")) 545 | ("Gu" . ("υ")) ("GU" . ("Υ")) 546 | ("Gf" . ("φ")) ("GF" . ("Φ")) 547 | ("Gc" . ("χ")) ("GC" . ("Χ")) 548 | ("Gp" . ("ψ")) ("GP" . ("Ψ")) 549 | ("Go" . ("ω")) ("GO" . ("Ω")) 550 | 551 | ;; Some ISO8859-1 characters. 552 | 553 | (" " . (" ")) 554 | ("!" . ("¡")) 555 | ("cent" . ("¢")) 556 | ("brokenbar" . ("¦")) 557 | ("degree" . ("°")) 558 | ("?" . ("¿")) 559 | ("^a_" . ("ª")) 560 | ("^o_" . ("º")) 561 | 562 | ,@(if (>= emacs-major-version 23) 563 | '(("pounds" . ("£")) 564 | ("currency" . ("¤")) 565 | ("yen" . ("¥")) 566 | ("S" . ("§")) 567 | ("\"{}" . ("¨")) 568 | ("copyright" . ("©")) 569 | ("flqq" . ("«")) 570 | ("\"<" . ("«")) 571 | ("-" . ("­")) 572 | ("registered" . ("®")) 573 | ("={}" . ("¯")) 574 | ("^2" . ("²")) 575 | ("^3" . ("³")) 576 | ("'{}" . ("´")) 577 | ("micro" . ("µ")) 578 | ("P" . ("¶")) 579 | ("c{}" . ("¸")) 580 | ("^1" . ("¹")) 581 | ("frqq" . ("»")) 582 | ("\">" . ("»")) 583 | ("frac14" . ("¼")) 584 | ("frac12" . ("½")) 585 | ("frac34" . ("¾")) 586 | ("`A" . ("À")) 587 | ("'A" . ("Á")) 588 | ("^A" . ("Â")) 589 | ("~A" . ("Ã")) 590 | ("\"A" . ("Ä")) 591 | ("AA" . ("Å")) 592 | ("AE" . ("Æ")) 593 | ("cC" . ("Ç")) 594 | ("`E" . ("È")) 595 | ("'E" . ("É")) 596 | ("^E" . ("Ê")) 597 | ("\"E" . ("Ë")) 598 | ("`I" . ("Ì")) 599 | ("'I" . ("Í")) 600 | ("^I" . ("Î")) 601 | ("\"I" . ("Ï")) 602 | ("DH" . ("Ð")) 603 | ("~N" . ("Ñ")) 604 | ("`O" . ("Ò")) 605 | ("'O" . ("Ó")) 606 | ("^O" . ("Ô")) 607 | ("~O" . ("Õ")) 608 | ("\"O" . ("Ö")) 609 | ("O" . ("Ø")) 610 | ("`U" . ("Ù")) 611 | ("'U" . ("Ú")) 612 | ("^U" . ("Û")) 613 | ("\"U" . ("Ü")) 614 | ("'Y" . ("Ý")) 615 | ("TH" . ("Þ")) 616 | ("ss" . ("ß")) 617 | ("`a" . ("à")) 618 | ("'a" . ("á")) 619 | ("^a" . ("â")) 620 | ("~a" . ("ã")) 621 | ("\"a" . ("ä")) 622 | ("aa" . ("å")) 623 | ("ae" . ("æ")) 624 | ("cc" . ("ç")) 625 | ("`e" . ("è")) 626 | ("'e" . ("é")) 627 | ("^e" . ("ê")) 628 | ("\"e" . ("ë")) 629 | ("`i" . ("ì")) 630 | ("'i" . ("í")) 631 | ("^i" . ("î")) 632 | ("\"i" . ("ï")) 633 | ("dh" . ("ð")) 634 | ("~n" . ("ñ")) 635 | ("`o" . ("ò")) 636 | ("'o" . ("ó")) 637 | ("^o" . ("ô")) 638 | ("~o" . ("õ")) 639 | ("\"o" . ("ö")) 640 | ("o" . ("ø")) 641 | ("`u" . ("ù")) 642 | ("'u" . ("ú")) 643 | ("^u" . ("û")) 644 | ("\"u" . ("ü")) 645 | ("'y" . ("ý")) 646 | ("th" . ("þ")) 647 | ("\"y" . ("ÿ")))) 648 | 649 | ;; Circled, parenthesised etc. numbers and letters. 650 | 651 | ( "(0)" . ,(agda-input-to-string-list " ⓪")) 652 | ( "(1)" . ,(agda-input-to-string-list "⑴①⒈❶➀➊")) 653 | ( "(2)" . ,(agda-input-to-string-list "⑵②⒉❷➁➋")) 654 | ( "(3)" . ,(agda-input-to-string-list "⑶③⒊❸➂➌")) 655 | ( "(4)" . ,(agda-input-to-string-list "⑷④⒋❹➃➍")) 656 | ( "(5)" . ,(agda-input-to-string-list "⑸⑤⒌❺➄➎")) 657 | ( "(6)" . ,(agda-input-to-string-list "⑹⑥⒍❻➅➏")) 658 | ( "(7)" . ,(agda-input-to-string-list "⑺⑦⒎❼➆➐")) 659 | ( "(8)" . ,(agda-input-to-string-list "⑻⑧⒏❽➇➑")) 660 | ( "(9)" . ,(agda-input-to-string-list "⑼⑨⒐❾➈➒")) 661 | ("(10)" . ,(agda-input-to-string-list "⑽⑩⒑❿➉➓")) 662 | ("(11)" . ,(agda-input-to-string-list "⑾⑪⒒")) 663 | ("(12)" . ,(agda-input-to-string-list "⑿⑫⒓")) 664 | ("(13)" . ,(agda-input-to-string-list "⒀⑬⒔")) 665 | ("(14)" . ,(agda-input-to-string-list "⒁⑭⒕")) 666 | ("(15)" . ,(agda-input-to-string-list "⒂⑮⒖")) 667 | ("(16)" . ,(agda-input-to-string-list "⒃⑯⒗")) 668 | ("(17)" . ,(agda-input-to-string-list "⒄⑰⒘")) 669 | ("(18)" . ,(agda-input-to-string-list "⒅⑱⒙")) 670 | ("(19)" . ,(agda-input-to-string-list "⒆⑲⒚")) 671 | ("(20)" . ,(agda-input-to-string-list "⒇⑳⒛")) 672 | 673 | ("(a)" . ,(agda-input-to-string-list "⒜Ⓐⓐ")) 674 | ("(b)" . ,(agda-input-to-string-list "⒝Ⓑⓑ")) 675 | ("(c)" . ,(agda-input-to-string-list "⒞Ⓒⓒ")) 676 | ("(d)" . ,(agda-input-to-string-list "⒟Ⓓⓓ")) 677 | ("(e)" . ,(agda-input-to-string-list "⒠Ⓔⓔ")) 678 | ("(f)" . ,(agda-input-to-string-list "⒡Ⓕⓕ")) 679 | ("(g)" . ,(agda-input-to-string-list "⒢Ⓖⓖ")) 680 | ("(h)" . ,(agda-input-to-string-list "⒣Ⓗⓗ")) 681 | ("(i)" . ,(agda-input-to-string-list "⒤Ⓘⓘ")) 682 | ("(j)" . ,(agda-input-to-string-list "⒥Ⓙⓙ")) 683 | ("(k)" . ,(agda-input-to-string-list "⒦Ⓚⓚ")) 684 | ("(l)" . ,(agda-input-to-string-list "⒧Ⓛⓛ")) 685 | ("(m)" . ,(agda-input-to-string-list "⒨Ⓜⓜ")) 686 | ("(n)" . ,(agda-input-to-string-list "⒩Ⓝⓝ")) 687 | ("(o)" . ,(agda-input-to-string-list "⒪Ⓞⓞ")) 688 | ("(p)" . ,(agda-input-to-string-list "⒫Ⓟⓟ")) 689 | ("(q)" . ,(agda-input-to-string-list "⒬Ⓠⓠ")) 690 | ("(r)" . ,(agda-input-to-string-list "⒭Ⓡⓡ")) 691 | ("(s)" . ,(agda-input-to-string-list "⒮Ⓢⓢ")) 692 | ("(t)" . ,(agda-input-to-string-list "⒯Ⓣⓣ")) 693 | ("(u)" . ,(agda-input-to-string-list "⒰Ⓤⓤ")) 694 | ("(v)" . ,(agda-input-to-string-list "⒱Ⓥⓥ")) 695 | ("(w)" . ,(agda-input-to-string-list "⒲Ⓦⓦ")) 696 | ("(x)" . ,(agda-input-to-string-list "⒳Ⓧⓧ")) 697 | ("(y)" . ,(agda-input-to-string-list "⒴Ⓨⓨ")) 698 | ("(z)" . ,(agda-input-to-string-list "⒵Ⓩⓩ")) 699 | 700 | )) 701 | "A list of translations specific to the Agda input method. 702 | Each element is a pair (KEY-SEQUENCE-STRING . LIST-OF-TRANSLATION-STRINGS). 703 | All the translation strings are possible translations 704 | of the given key sequence; if there is more than one you can choose 705 | between them using the arrow keys. 706 | 707 | Note that if you customize this setting you will not 708 | automatically benefit (or suffer) from modifications to its 709 | default value when the library is updated. If you just want to 710 | add some bindings it is probably a better idea to customize 711 | `agda-input-user-translations'. 712 | 713 | If you change this setting manually (without using the 714 | customization buffer) you need to call `agda-input-setup' in 715 | order for the change to take effect." 716 | :group 'agda-input 717 | :set 'agda-input-incorporate-changed-setting 718 | :initialize 'custom-initialize-default 719 | :type '(repeat (cons (string :tag "Key sequence") 720 | (repeat :tag "Translations" string)))) 721 | 722 | 723 | (defcustom agda-input-user-translations nil 724 | "Like `agda-input-translations', but more suitable for user 725 | customizations since by default it is empty." 726 | :group 'agda-input 727 | :set 'agda-input-incorporate-changed-setting 728 | :initialize 'custom-initialize-default 729 | :type '(repeat (cons (string :tag "Key sequence") 730 | (repeat :tag "Translations" string)))) 731 | 732 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 733 | ;; Inspecting and modifying translation maps 734 | 735 | (defun agda-input-get-translations (qp) 736 | "Return a list containing all translations from the Quail 737 | package QP (except for those corresponding to ASCII). 738 | Each pair in the list has the form (KEY-SEQUENCE . TRANSLATION)." 739 | (with-temp-buffer 740 | (activate-input-method qp) ; To make sure that the package is loaded. 741 | (unless (quail-package qp) 742 | (error "%s is not a Quail package." qp)) 743 | (let ((decode-map (list 'decode-map))) 744 | (quail-build-decode-map (list (quail-map)) "" decode-map 0) 745 | (cdr decode-map)))) 746 | 747 | (defun agda-input-show-translations (qp) 748 | "Display all translations used by the Quail package QP (a string). 749 | \(Except for those corresponding to ASCII)." 750 | (interactive (list (read-input-method-name 751 | "Quail input method (default %s): " "Agda"))) 752 | (let ((buf (concat "*" qp " input method translations*"))) 753 | (with-output-to-temp-buffer buf 754 | (with-current-buffer buf 755 | (quail-insert-decode-map 756 | (cons 'decode-map (agda-input-get-translations qp))))))) 757 | 758 | (defun agda-input-add-translations (trans) 759 | "Add the given translations TRANS to the Agda input method. 760 | TRANS is a list of pairs (KEY-SEQUENCE . TRANSLATION)." 761 | (with-temp-buffer 762 | (dolist (tr (agda-input-concat-map (eval agda-input-tweak-all) trans)) 763 | (quail-defrule (car tr) (cdr tr) "Agda" t)))) 764 | 765 | (defun agda-input-inherit-package (qp &optional fun) 766 | "Let the Agda input method inherit the translations from the 767 | Quail package QP (except for those corresponding to ASCII). 768 | 769 | The optional function FUN can be used to modify the translations. 770 | It is given a pair (KEY-SEQUENCE . TRANSLATION) and should return 771 | a list of such pairs." 772 | (let ((trans (agda-input-get-translations qp))) 773 | (agda-input-add-translations 774 | (if fun (agda-input-concat-map fun trans) 775 | trans)))) 776 | 777 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 778 | ;; Setting up the input method 779 | 780 | (defun agda-input-setup () 781 | "Set up the Agda input method based on the customisable 782 | variables and underlying input methods." 783 | 784 | ;; Create (or reset) the input method. 785 | (with-temp-buffer 786 | (quail-define-package "Agda" "UTF-8" "∏" t ; guidance 787 | "Agda input method. 788 | The purpose of this input method is to edit Agda programs, but 789 | since it is highly customisable it can be made useful for other 790 | tasks as well." 791 | nil nil nil nil nil nil t ; maximum-shortest 792 | )) 793 | 794 | (agda-input-add-translations 795 | (mapcar (lambda (tr) (cons (car tr) (vconcat (cdr tr)))) 796 | (append agda-input-user-translations 797 | agda-input-translations))) 798 | (dolist (def agda-input-inherit) 799 | (agda-input-inherit-package (car def) 800 | (eval (cdr def))))) 801 | 802 | (defun agda-input-incorporate-changed-setting (sym val) 803 | "Update the Agda input method based on the customisable 804 | variables and underlying input methods. 805 | Suitable for use in the :set field of `defcustom'." 806 | (set-default sym val) 807 | (agda-input-setup)) 808 | 809 | ;; Set up the input method. 810 | 811 | (agda-input-setup) 812 | 813 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 814 | ;; Administrative details 815 | 816 | (provide 'agda-input) 817 | ;;; agda-input.el ends here 818 | -------------------------------------------------------------------------------- /modes/agda2/agda2-mode.el: -------------------------------------------------------------------------------- 1 | ;;; agda2-mode.el --- Major mode for Agda2 2 | 3 | ;;; Commentary: 4 | 5 | ;; 6 | 7 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 8 | ;;;; Dependency 9 | 10 | 11 | ;;; Code: 12 | 13 | (require 'cl) ; haskell-indent requires it anyway. 14 | (set (make-local-variable 'lisp-indent-function) 15 | 'common-lisp-indent-function) 16 | (require 'comint) 17 | (require 'pp) 18 | (require 'eri) 19 | (require 'agda-input) 20 | (require 'agda2-highlight) 21 | (require 'agda2-abbrevs) 22 | (require 'haskell-indent) 23 | (require 'haskell-ghci) 24 | ;; due to a bug in haskell-mode-2.1 25 | (setq haskell-ghci-mode-map (copy-keymap comint-mode-map)) 26 | ;; Load filladapt, if it is installed. 27 | (condition-case nil 28 | (require 'filladapt) 29 | (error nil)) 30 | (unless (fboundp 'overlays-in) (load "overlay")) ; for Xemacs 31 | (unless (fboundp 'propertize) ; for Xemacs 21.4 32 | (defun propertize (string &rest properties) 33 | "Return a copy of STRING with text properties added. 34 | First argument is the string to copy. 35 | Remaining arguments form a sequence of PROPERTY VALUE pairs for text 36 | properties to add to the result." 37 | (let ((str (copy-sequence string))) 38 | (add-text-properties 0 (length str) properties str) 39 | str))) 40 | (unless (fboundp 'run-mode-hooks) 41 | (fset 'run-mode-hooks 'run-hooks)) ; For Emacs versions < 21. 42 | 43 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 44 | ;;;; Programming utilities 45 | 46 | (defmacro agda2-protect (form &optional default) 47 | "Expands to (condition-case nil FORM (error DEFAULT))." 48 | `(condition-case nil ,form (error ,default))) 49 | (put 'agda2-protect 'lisp-indent-function 0) 50 | (defmacro agda2-let (varbind funcbind &rest body) 51 | "Expands to (let* VARBIND (labels FUNCBIND BODY...))." 52 | `(let* ,varbind (labels ,funcbind ,@body))) 53 | (put 'agda2-let 'lisp-indent-function 2) 54 | 55 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 56 | ;;;; User options 57 | 58 | (defgroup agda2 nil 59 | "Major mode for interactively developing Agda programs." 60 | :group 'languages) 61 | 62 | (defcustom agda2-include-dirs 63 | '(".") 64 | "The directories Agda uses to search for files. 65 | The directory names should be relative to the root of the current project." 66 | :type '(repeat directory) 67 | :group 'agda2) 68 | 69 | (defcustom agda2-ghci-options 70 | (list "-package Agda") 71 | "Options set in GHCi before loading `agda2-toplevel-module'. 72 | Note that only dynamic options can be set using this variable." 73 | :type '(repeat string) 74 | :group 'agda2) 75 | 76 | (defcustom agda2-toplevel-module "Agda.Interaction.GhciTop" 77 | "The name of the Agda2 toplevel module." 78 | :type 'string :group 'agda2) 79 | 80 | (defcustom agda2-mode-hook 81 | '(agda2-fix-ghci-for-windows) 82 | "Hooks for `agda2-mode'." 83 | :type 'hook :group 'agda2) 84 | 85 | (defcustom agda2-indentation 86 | 'eri 87 | "*The kind of indentation used in `agda2-mode'." 88 | :type '(choice (const :tag "Haskell" haskell) 89 | (const :tag "Extended relative" eri) 90 | (const :tag "None" nil)) 91 | :group 'agda2) 92 | 93 | (defcustom agda2-fontset-name "fontset-agda2" 94 | "Default font to use in the selected frame when activating the Agda2 mode. 95 | This is only used if it's non-nil and Emacs is not running in a terminal. 96 | It is also ignored in Emacs 23 and up, where the improved font handling makes 97 | it unnecessary. 98 | 99 | Note that this setting (if non-nil) affects non-Agda buffers as 100 | well, and that you have to restart Emacs if you want settings to 101 | this variable to take effect." 102 | :type '(choice (string :tag "Fontset name") 103 | (const :tag "Do not change the font" nil)) 104 | :group 'agda2) 105 | 106 | (defcustom agda2-fontset-spec-of-fontset-agda2 107 | "-*-fixed-Medium-r-Normal-*-18-*-*-*-c-*-fontset-agda2, 108 | ascii:-Misc-Fixed-Medium-R-Normal--18-120-100-100-C-90-ISO8859-1, 109 | latin-iso8859-2:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-2, 110 | latin-iso8859-3:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-3, 111 | latin-iso8859-4:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-4, 112 | cyrillic-iso8859-5:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-5, 113 | greek-iso8859-7:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-7, 114 | latin-iso8859-9:-*-Fixed-*-r-*-*-18-*-*-*-c-*-iso8859-9, 115 | mule-unicode-0100-24ff:-Misc-Fixed-Medium-R-Normal--18-120-100-100-C-90-ISO10646-1, 116 | mule-unicode-2500-33ff:-Misc-Fixed-Medium-R-Normal--18-120-100-100-C-90-ISO10646-1, 117 | mule-unicode-e000-ffff:-Misc-Fixed-Medium-R-Normal--18-120-100-100-C-90-ISO10646-1, 118 | japanese-jisx0208:-Misc-Fixed-Medium-R-Normal-ja-18-*-*-*-C-*-JISX0208.1990-0, 119 | japanese-jisx0212:-Misc-Fixed-Medium-R-Normal-ja-18-*-*-*-C-*-JISX0212.1990-0, 120 | thai-tis620:-Misc-Fixed-Medium-R-Normal--24-240-72-72-C-120-TIS620.2529-1, 121 | lao:-Misc-Fixed-Medium-R-Normal--24-240-72-72-C-120-MuleLao-1, 122 | tibetan:-TibMdXA-fixed-medium-r-normal--16-160-72-72-m-160-MuleTibetan-0, 123 | tibetan-1-column:-TibMdXA-fixed-medium-r-normal--16-160-72-72-m-80-MuleTibetan-1, 124 | korean-ksc5601:-Daewoo-Mincho-Medium-R-Normal--16-120-100-100-C-160-KSC5601.1987-0, 125 | chinese-gb2312:-ISAS-Fangsong ti-Medium-R-Normal--16-160-72-72-c-160-GB2312.1980-0, 126 | chinese-cns11643-1:-HKU-Fixed-Medium-R-Normal--16-160-72-72-C-160-CNS11643.1992.1-0, 127 | chinese-big5-1:-ETen-Fixed-Medium-R-Normal--16-150-75-75-C-160-Big5.ETen-0, 128 | chinese-big5-2:-ETen-Fixed-Medium-R-Normal--16-150-75-75-C-160-Big5.ETen-0" 129 | "Specification of the \"fontset-agda2\" fontset. 130 | The \"fontset-agda2\" is the standard setting for `agda2-fontset-name'. 131 | If `agda2-fontset-name' is nil, or Emacs is 132 | run in a terminal, then \"fontset-agda2\" is not created. 133 | 134 | Note that the text \"fontset-agda2\" has to be part of the 135 | string (in a certain way; see the default setting) in order for the 136 | agda2 fontset to be created properly. 137 | 138 | Note also that the default setting may not work unless suitable 139 | fonts are installed on your system. Refer to the README file 140 | accompanying the Agda distribution for details. 141 | 142 | Note finally that you have to restart Emacs if you want settings 143 | to this variable to take effect." 144 | :group 'agda2 145 | :type 'string) 146 | 147 | (if (and agda2-fontset-name window-system) 148 | (create-fontset-from-fontset-spec agda2-fontset-spec-of-fontset-agda2 t t)) 149 | 150 | (defun agda2-fix-ghci-for-windows () 151 | (if (string-match "windows" system-configuration) 152 | (setq haskell-ghci-program-name "ghc" 153 | haskell-ghci-program-args '("--interactive")))) 154 | 155 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 156 | ;;;; Global and buffer-local vars, initialization 157 | 158 | (defvar agda2-mode-syntax-table 159 | (let ((tbl (make-syntax-table))) 160 | ;; Set the syntax of every char to "w" except for those whose default 161 | ;; syntax in `standard-syntax-table' is `paren' or `whitespace'. 162 | (map-char-table (lambda (keys val) 163 | ;; `keys' here can be a normal char, a generic char 164 | ;; (Emacs<23), or a char range (Emacs>=23). 165 | (unless (memq (car val) 166 | (eval-when-compile 167 | (mapcar 'car 168 | (list (string-to-syntax "(") 169 | (string-to-syntax ")") 170 | (string-to-syntax " "))))) 171 | (modify-syntax-entry keys "w" tbl))) 172 | (standard-syntax-table)) 173 | ;; Then override the remaining special cases. 174 | (dolist (cs '((?{ . "(}1n") (?} . "){4n") (?- . "w 123b") (?\n . "> b") 175 | (?. . ".") (?\; . ".") (?_ . ".") (?! . "."))) 176 | (modify-syntax-entry (car cs) (cdr cs) tbl)) 177 | tbl) 178 | "Syntax table used by the Agda 2 mode: 179 | 180 | {} | Comment characters, matching parentheses. 181 | - | Comment character, word constituent. 182 | \n | Comment ender. 183 | .;_! | Punctuation. 184 | 185 | Remaining characters inherit their syntax classes from the 186 | standard syntax table if that table treats them as matching 187 | parentheses or whitespace. Otherwise they are treated as word 188 | constituents.") 189 | 190 | (defconst agda2-command-table 191 | `( 192 | (agda2-load "\C-c\C-l" (global) "Load") 193 | (agda2-load "\C-c\C-x\C-l") 194 | (agda2-compile "\C-c\C-x\C-c" (global) "Compile") 195 | (agda2-text-state "\C-c\C-x\C-d" (global) "Deactivate Agda") 196 | (agda2-quit "\C-c\C-x\C-q" (global) "Quit") 197 | (agda2-restart "\C-c\C-x\C-r" (global) "Restart") 198 | (agda2-display-implicit-arguments "\C-c\C-x\C-h" (global) "Toggle display of hidden arguments") 199 | (agda2-highlight-reload-or-clear "\C-c\C-x\C-s" (global) "Reload syntax highlighting information") 200 | (agda2-show-constraints ,(kbd "C-c C-=") (global) "Show constraints") 201 | (agda2-solveAll ,(kbd "C-c C-s") (global) "Solve constraints") 202 | (agda2-show-goals ,(kbd "C-c C-?") (global) "Show goals") 203 | (agda2-next-goal "\C-c\C-f" (global) "Next goal") ; Forward. 204 | (agda2-previous-goal "\C-c\C-b" (global) "Previous goal") ; Back. 205 | (agda2-give ,(kbd "C-c C-SPC") (local) "Give") 206 | (agda2-refine "\C-c\C-r" (local) "Refine") 207 | (agda2-make-case "\C-c\C-c" (local) "Case") 208 | (agda2-goal-type "\C-c\C-t" (local) "Goal type") 209 | (agda2-show-context "\C-c\C-e" (local) "Context (environment)") 210 | (agda2-infer-type-maybe-toplevel "\C-c\C-d" (local global) "Infer (deduce) type") 211 | (agda2-goal-and-context ,(kbd "C-c C-,") (local) "Goal type and context") 212 | (agda2-goal-and-context-and-inferred ,(kbd "C-c C-.") (local) "Goal type, context and inferred type") 213 | (agda2-compute-normalised-maybe-toplevel "\C-c\C-n" (local global) "Evaluate term to normal form") 214 | (agda2-indent ,(kbd "TAB")) 215 | (agda2-indent-reverse [S-iso-lefttab]) 216 | (agda2-indent-reverse [S-lefttab]) 217 | (agda2-indent-reverse [S-tab]) 218 | (agda2-goto-definition-mouse [mouse-2]) 219 | (agda2-goto-definition-keyboard "\M-.") 220 | (agda2-go-back "\M-*") 221 | ) 222 | "Table of commands, used to build keymaps and menus. 223 | Each element has the form (CMD KEY &optional NAME GOAL-NAME) 224 | Where NAME is the name to use in the main Agda2 menu 225 | and GOAL-NAME is for the Agda goal menu.") 226 | 227 | (defvar agda2-mode-map 228 | (let ((map (make-sparse-keymap "Agda mode"))) 229 | (define-key map [menu-bar Agda2] 230 | (cons "Agda2" (make-sparse-keymap "Agda2"))) 231 | (define-key map [down-mouse-3] 'agda2-popup-menu-3) 232 | (dolist (d (reverse agda2-command-table)) 233 | (destructuring-bind (f &optional keys kinds desc) d 234 | (if keys (define-key map keys f)) 235 | (if (member 'global kinds) 236 | (define-key map 237 | (vector 'menu-bar 'Agda2 (intern desc)) (cons desc f))))) 238 | map) 239 | "Keymap for `agda2-mode'.") 240 | 241 | (defvar agda2-goal-map 242 | (let ((map (make-sparse-keymap "Agda goal"))) 243 | (dolist (d (reverse agda2-command-table)) 244 | (destructuring-bind (f &optional keys kinds desc) d 245 | (if (member 'local kinds) 246 | (define-key map 247 | (vector (intern desc)) (cons desc f))))) 248 | map) 249 | "Keymap for agda2 goal menu.") 250 | 251 | (defvar agda2-buffer nil "Agda subprocess buffer. Set in `agda2-restart'.") 252 | (defvar agda2-process nil "Agda subprocess. Set in `agda2-restart'.") 253 | 254 | ;; Some buffer locals 255 | (defvar agda2-buffer-state "Text" 256 | "State of an `agda2-mode' buffer. \"Text\" or \"Checked\".") 257 | (make-variable-buffer-local 'agda2-buffer-state) 258 | (defvar agda2-buffer-external-status "" 259 | "External status of an `agda2-mode' buffer (dictated by the Haskell side).") 260 | (make-variable-buffer-local 'agda2-buffer-external-status) 261 | 262 | (defconst agda2-help-address 263 | "" 264 | "Address accepting submissions of bug reports and questions.") 265 | 266 | ;; Annotation for a goal 267 | ;; {! .... !} 268 | ;; ---------- overlay: agda2-gn num, face highlight , after-string num 269 | ;; - text-props: agda2-gn num, intangible left , read-only 270 | ;; - text-props: invisible, intangible left , read-only 271 | ;; - text-props: invisible, intangible right, read-only 272 | ;; - text-props: intangible right, read-only 273 | ;; Goal number agda2-gn is duplicated in overlay and text-prop so that 274 | ;; overlay can be re-made after undo. (If we had an Agda-aware undo 275 | ;; feature.) 276 | ;; 277 | ;; Char categories for {! ... !} 278 | (flet ((stpl (c ps) (setplist c (append '(read-only t rear-nonsticky t 279 | intangible) ps)))) 280 | (stpl 'agda2-delim1 '(left)) 281 | (stpl 'agda2-delim2 '(left invisible t)) 282 | (stpl 'agda2-delim3 '(right invisible t)) 283 | (stpl 'agda2-delim4 '(right))) 284 | 285 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 286 | ;;;; agda2-mode 287 | 288 | ;;;###autoload 289 | (add-to-list 'auto-mode-alist '("\\.l?agda\\'" . agda2-mode)) 290 | ;;;###autoload 291 | (modify-coding-system-alist 'file "\\.l?agda\\'" 'utf-8) 292 | ;;;###autoload 293 | (define-derived-mode agda2-mode nil "Agda2" 294 | "Major mode for agda2 files. 295 | 296 | Note that when this mode is activated the default font of the 297 | current frame is changed to the fontset `agda2-fontset-name'. 298 | The reason is that Agda programs often use mathematical symbols 299 | and other Unicode characters, so we try to provide a suitable 300 | default font setting, which can display many of the characters 301 | encountered. If you prefer to use your own settings, set 302 | `agda2-fontset-name' to nil. 303 | 304 | Special commands: 305 | \\{agda2-mode-map}" 306 | (setq local-abbrev-table agda2-mode-abbrev-table 307 | indent-tabs-mode nil 308 | mode-line-process 309 | '(":" (:eval agda2-buffer-state) 310 | (:eval (unless (eq 0 (length agda2-buffer-external-status)) 311 | (concat "(" agda2-buffer-external-status ")"))))) 312 | (let ((l '(max-specpdl-size 2600 313 | max-lisp-eval-depth 2800))) 314 | (while l (set (make-local-variable (pop l)) (pop l)))) 315 | (if (and window-system agda2-fontset-name 316 | ;; Emacs-23 uses a revamped font engine which should make 317 | ;; agda2-fontset-name unnecessary in most cases. And if it turns out 318 | ;; to be necessary, we should probably use face-remapping-alist 319 | ;; rather than set-frame-font so the special font only applies to 320 | ;; Agda buffers, and so it applies in all frames where Agda 321 | ;; buffers are displayed. 322 | (not (boundp 'face-remapping-alist))) 323 | (condition-case nil 324 | (set-frame-font agda2-fontset-name) 325 | (error (error "Unable to change the font; change agda2-fontset-name or tweak agda2-fontset-spec-fontset-agda2")))) 326 | (agda2-indent-setup) 327 | (agda2-highlight-setup) 328 | (agda2-highlight-reload) 329 | (agda2-comments-and-paragraphs-setup) 330 | (force-mode-line-update) 331 | (set-input-method "Agda")) 332 | 333 | (defun agda2-restart () 334 | "Kill and restart the *ghci* buffer and load `agda2-toplevel-module'." 335 | (interactive) 336 | (save-excursion (let ((agda2-bufname "*ghci*") 337 | (ignore-dot-ghci "-ignore-dot-ghci")) 338 | (agda2-protect (kill-buffer agda2-bufname)) 339 | ;; Make sure that the user's .ghci is not read. 340 | ;; Users can override this by adding 341 | ;; "-read-dot-ghci" to 342 | ;; `haskell-ghci-program-args'. 343 | (unless (equal (car-safe haskell-ghci-program-args) 344 | ignore-dot-ghci) 345 | (set (make-local-variable 'haskell-ghci-program-args) 346 | (cons ignore-dot-ghci haskell-ghci-program-args))) 347 | (haskell-ghci-start-process nil) 348 | (setq agda2-process haskell-ghci-process 349 | agda2-buffer haskell-ghci-process-buffer 350 | mode-name "Agda2 GHCi") 351 | (set-buffer-file-coding-system 'utf-8) 352 | (set-buffer-process-coding-system 'utf-8 'utf-8) 353 | (rename-buffer agda2-bufname))) 354 | (apply 'agda2-go ":set" agda2-ghci-options) 355 | (agda2-go ":mod +" agda2-toplevel-module) 356 | (agda2-text-state)) 357 | 358 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 359 | ;;;; Communicating with Agda2 360 | 361 | (defun agda2-go (&rest args) 362 | "Send the list ARGS of strings to ghci, then 363 | wait for output and execute responses, if any" 364 | (interactive) 365 | (unless (eq 'run (agda2-process-status)) 366 | ;; Try restarting automatically, but only once, in case there is 367 | ;; some major problem. 368 | (agda2-restart) 369 | (unless (eq 'run (agda2-process-status)) 370 | (error "Problem encountered. The *ghci* buffer can perhaps explain why."))) 371 | (save-excursion 372 | (haskell-ghci-go (apply 'concat (agda2-intersperse " " args)) nil)) 373 | ;;(display-buffer agda2-buffer 'not-tihs-window) 374 | (let (response) 375 | (with-current-buffer haskell-ghci-process-buffer 376 | (haskell-ghci-wait-for-output) 377 | ;; Note that the following code may be prone to race conditions 378 | ;; (make-temp-file returns a filename, not an open file). This is 379 | ;; not likely to be a problem, though. 380 | (let ((tempfile (make-temp-file "agda2-mode"))) 381 | (unwind-protect 382 | (progn 383 | (comint-write-output tempfile) 384 | (with-temp-buffer 385 | (insert-file-contents tempfile) 386 | (setq response (buffer-substring-no-properties 387 | (point-min) (point-max))))) 388 | (delete-file tempfile)))) 389 | (agda2-respond response))) 390 | 391 | (defun agda2-goal-cmd (cmd &optional want ask &rest args) 392 | "When in a goal, send CMD, goal num and range, and strings ARGS to agda2. 393 | WANT is an optional prompt. When ASK is non-nil, use minibuffer." 394 | (multiple-value-bind (o g) (agda2-goal-at (point)) 395 | (unless g (error "For this command, please place the cursor in a goal")) 396 | (let ((txt (buffer-substring-no-properties (+ (overlay-start o) 2) 397 | (- (overlay-end o) 2)))) 398 | (if (not want) (setq txt "") 399 | (when (or ask (string-match "\\`\\s *\\'" txt)) 400 | (setq txt (read-string (concat want ": ") txt)))) 401 | (apply 'agda2-go cmd 402 | (format "%d" g) 403 | (agda2-goal-Range o) 404 | (agda2-string-quote txt) args)))) 405 | 406 | (defun agda2-respond (response) 407 | "Execute 'agda2_mode_code' within RESPONSE string." 408 | (while (string-match "agda2_mode_code" response) 409 | (setq response (substring response (match-end 0))) 410 | (let ((inhibit-read-only t) 411 | (inhibit-point-motion-hooks t)) 412 | (eval (read response))))) 413 | 414 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 415 | ;;;; User commands and response processing 416 | 417 | (defun agda2-load () 418 | "Load current buffer." 419 | (interactive) 420 | (agda2-go "cmd_load" 421 | (agda2-string-quote (buffer-file-name)) 422 | (agda2-list-quote agda2-include-dirs) 423 | )) 424 | 425 | (defun agda2-compile () 426 | "Compile the current module." 427 | (interactive) 428 | (agda2-go "cmd_compile" 429 | (agda2-string-quote (buffer-file-name)) 430 | (agda2-list-quote agda2-include-dirs) 431 | )) 432 | 433 | (defun agda2-load-action (gs) 434 | "Annotate new goals GS in current buffer." 435 | (agda2-forget-all-goals) 436 | (agda2-annotate gs (point-min)) 437 | (setq agda2-buffer-state "Checked")) 438 | 439 | (defun agda2-give() 440 | "Give to the goal at point the expression in it" (interactive) 441 | (agda2-goal-cmd "cmd_give" "expression to give")) 442 | 443 | (defun agda2-give-action (old-g paren new-gs) 444 | "Update the goal OLD-G with the expression in it and 445 | annotate new goals NEW-GS" 446 | (agda2-update old-g paren new-gs)) 447 | 448 | (defun agda2-refine () 449 | "Refine the goal at point by the expression in it." (interactive) 450 | (agda2-goal-cmd "cmd_refine" "expression to refine")) 451 | 452 | (defun agda2-make-case () 453 | "Refine the pattern var given in the goal. 454 | Assumes that = {!!} is on one line." 455 | (interactive) 456 | (agda2-goal-cmd "cmd_make_case" "partten var to case")) 457 | 458 | (defun agda2-make-case-action (newcls) 459 | "Replace the line at point with new clauses NEWCLS and reload." 460 | (agda2-forget-all-goals);; we reload later anyway. 461 | (let* ((p0 (point)) 462 | ;; (p1 (goto-char (agda2-decl-beginning))) 463 | (p1 (goto-char (+ (current-indentation) (line-beginning-position)))) 464 | (indent (current-column)) 465 | cl) 466 | (goto-char p0) 467 | (re-search-forward "!}" (line-end-position) 'noerr) 468 | (delete-region p1 (point)) 469 | (while (setq cl (pop newcls)) 470 | (insert cl) 471 | (if newcls (insert "\n" (make-string indent ? )))) 472 | (goto-char p1)) 473 | (agda2-load)) 474 | 475 | (defun agda2-status-action (status) 476 | "Display the string STATUS in the current buffer's mode line. 477 | \(precondition: the current buffer has to use the Agda mode as the 478 | major mode)." 479 | (interactive) ;FIXME: Why?? 480 | (setq agda2-buffer-external-status status)) 481 | 482 | (defun agda2-info-action (name text) 483 | "Insert TEXT into the Agda info buffer, display it, and display NAME 484 | in the buffer's mode line." 485 | (interactive) 486 | (with-current-buffer (get-buffer-create "*Agda2 information*") 487 | (erase-buffer) 488 | (insert text) 489 | (set-syntax-table agda2-mode-syntax-table) 490 | (set-input-method "Agda") 491 | (goto-char (point-min)) 492 | (put-text-property 0 (length name) 'face '(:weight bold) name) 493 | (setq mode-line-buffer-identification name) 494 | (save-selected-window 495 | (pop-to-buffer (current-buffer) 'not-this-window 'norecord) 496 | (shrink-window 497 | (- (window-height) 498 | (min (/ (frame-height) 2) 499 | (max window-min-height 500 | (1+ (count-lines (point-min) (point-max)))))))))) 501 | 502 | (defun agda2-show-goals() 503 | "Show all goals." (interactive) 504 | (agda2-go "cmd_metas")) 505 | 506 | (defun agda2-show-constraints() 507 | "Show constraints." (interactive) 508 | (agda2-go "cmd_constraints")) 509 | 510 | (defun agda2-text-state () 511 | "UNDER CONSTRUCTION" (interactive) 512 | (dolist (o (overlays-in (point-min) (point-max))) 513 | (delete-overlay o)) 514 | (agda2-go "cmd_reset") 515 | (let ((inhibit-read-only t) (inhibit-point-motion-hooks t)) 516 | (agda2-no-modified-p 'remove-text-properties 517 | (point-min) (point-max) 518 | '(category intangible read-only 519 | invisible agda2-gn)) 520 | (setq agda2-buffer-state "Text") 521 | (force-mode-line-update))) 522 | 523 | (defun agda2-next-goal () "Go to the next goal, if any." (interactive) 524 | (agda2-mv-goal 'next-single-property-change 'agda2-delim2 1 (point-min))) 525 | (defun agda2-previous-goal () "Go to the previous goal, if any." (interactive) 526 | (agda2-mv-goal 'previous-single-property-change 'agda2-delim3 0 (point-max))) 527 | (defun agda2-mv-goal (change delim adjust wrapped) 528 | (agda2-let ((inhibit-point-motion-hooks t)) 529 | ((go (p) (while (and (setq p (funcall change p 'category)) 530 | (not (eq (get-text-property p 'category) delim)))) 531 | (if p (goto-char (+ adjust p))))) 532 | (or (go (point)) (go wrapped) (message "No goals in the buffer")))) 533 | 534 | (defun agda2-quit () 535 | "Quit and clean up after agda2." (interactive) 536 | (agda2-protect (progn (kill-buffer agda2-buffer) 537 | (kill-buffer (current-buffer))))) 538 | 539 | (defmacro agda2-maybe-normalised (name comment cmd prompt) 540 | "This macro constructs a function NAME which runs CMD. 541 | COMMENT is used to build the function's comment. The function 542 | NAME takes a prefix argument which tells whether it should 543 | normalise types or not when running CMD (through 544 | `agda2-goal-cmd'; PROMPT, if non-nil, is used as the goal command 545 | prompt)." 546 | (let ((eval (make-symbol "eval"))) 547 | `(defun ,name (&optional not-normalise) 548 | ,(concat comment ". 549 | 550 | With a prefix argument the result is not explicitly normalised.") 551 | (interactive "P") 552 | (let ((,eval (if not-normalise "Instantiated" "Normalised"))) 553 | (agda2-goal-cmd (concat ,cmd " Agda.Interaction.BasicOps." ,eval) 554 | ,prompt))))) 555 | 556 | (defmacro agda2-maybe-normalised-toplevel (name comment cmd prompt) 557 | "This macro constructs a function NAME which runs CMD. 558 | COMMENT is used to build the function's comments. The function 559 | NAME takes a prefix argument which tells whether it should 560 | normalise types or not when running CMD (through `agda2-go'; the 561 | string PROMPT is used as the goal command prompt)." 562 | (let ((eval (make-symbol "eval"))) 563 | `(defun ,name (not-normalise expr) 564 | ,(concat comment ". 565 | 566 | With a prefix argument the result is not explicitly normalised.") 567 | (interactive ,(concat "P\nM" prompt ": ")) 568 | (let ((,eval (if not-normalise "Instantiated" "Normalised"))) 569 | (agda2-go (concat ,cmd " Agda.Interaction.BasicOps." ,eval " " 570 | (agda2-string-quote expr))))))) 571 | 572 | (agda2-maybe-normalised 573 | agda2-goal-type 574 | "Show the type of the goal at point" 575 | "cmd_goal_type" 576 | nil) 577 | 578 | (agda2-maybe-normalised 579 | agda2-infer-type 580 | "Infer the type of the goal at point" 581 | "cmd_infer" 582 | "expression to type") 583 | 584 | (agda2-maybe-normalised-toplevel 585 | agda2-infer-type-toplevel 586 | "Infers the type of the given expression. The scope used for 587 | the expression is that of the last point inside the current 588 | top-level module" 589 | "cmd_infer_toplevel" 590 | "Expression") 591 | 592 | (defun agda2-infer-type-maybe-toplevel () 593 | "Infers the type of the given expression. 594 | Either uses the scope of the current goal or, if point is not in a goal, the 595 | top-level scope." 596 | (interactive) 597 | (call-interactively (if (agda2-goal-at (point)) 598 | 'agda2-infer-type 599 | 'agda2-infer-type-toplevel))) 600 | 601 | (agda2-maybe-normalised 602 | agda2-goal-and-context 603 | "Shows the type of the goal at point and the currect context" 604 | "cmd_goal_type_context" 605 | nil) 606 | 607 | (agda2-maybe-normalised 608 | agda2-goal-and-context-and-inferred 609 | "Shows the context, the goal and the given expression's inferred type" 610 | "cmd_goal_type_context_infer" 611 | "expression to type") 612 | 613 | (agda2-maybe-normalised 614 | agda2-show-context 615 | "Show the context of the goal at point" 616 | "cmd_context" 617 | nil) 618 | 619 | (defun agda2-solveAll () 620 | "Solve all goals that are internally already instantiated." (interactive) 621 | (agda2-go "cmd_solveAll" )) 622 | 623 | (defun agda2-solveAll-action (iss) 624 | (save-excursion 625 | (while iss 626 | (let* ((g (pop iss)) (txt (pop iss))) 627 | (agda2-replace-goal g txt) 628 | (agda2-goto-goal g) 629 | (agda2-give))))) 630 | 631 | (defun agda2-compute-normalised (&optional arg) 632 | "Compute the normal form of the expression in the goal at point. 633 | With a prefix argument \"abstract\" is ignored during the computation." 634 | (interactive "P") 635 | (let ((cmd (concat "cmd_compute" 636 | (if arg " True" " False")))) 637 | (agda2-goal-cmd cmd "expression to normalise"))) 638 | 639 | (defun agda2-compute-normalised-toplevel (expr &optional arg) 640 | "Computes the normal form of the given expression. 641 | The scope used for the expression is that of the last point inside the current 642 | top-level module. 643 | With a prefix argument \"abstract\" is ignored during the computation." 644 | (interactive "MExpression: \nP") 645 | (let ((cmd (concat "cmd_compute_toplevel" 646 | (if arg " True" " False") 647 | " "))) 648 | (agda2-go (concat cmd (agda2-string-quote expr))))) 649 | 650 | (defun agda2-compute-normalised-maybe-toplevel () 651 | "Computes the normal form of the given expression, 652 | using the scope of the current goal or, if point is not in a goal, the 653 | top-level scope. 654 | With a prefix argument \"abstract\" is ignored during the computation." 655 | (interactive) 656 | (if (agda2-goal-at (point)) 657 | (call-interactively 'agda2-compute-normalised) 658 | (call-interactively 'agda2-compute-normalised-toplevel))) 659 | 660 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 661 | ;;;; 662 | 663 | (defun agda2-annotate (goals pos) 664 | "Find GOALS in the current buffer starting from POS and annotate them 665 | with text-properties" 666 | 667 | (agda2-let (stk top (inhibit-point-motion-hooks t)) 668 | ((delims() (re-search-forward "[?]\\|[{][-!]\\|[-!][}]\\|--" nil t)) 669 | (is-lone-questionmark () 670 | (save-excursion 671 | (save-match-data 672 | (backward-char 3) 673 | (looking-at 674 | "\\({!\\|.{\\|(\\|.\\s \\)[?]\\(\\s \\|)\\|}\\|!}\\|$\\)")))) 675 | (make(p) (agda2-make-goal p (point) (pop goals))) 676 | (err() (error "Unbalanced \{- , -\} , \{\! , \!\}"))) 677 | (save-excursion 678 | (goto-char pos) 679 | (while (and goals (delims)) 680 | (labels ((c (s) (equal s (match-string 0)))) 681 | (cond 682 | ((and (c "--") (not stk)) (end-of-line)) 683 | ((c "{-") (push nil stk)) 684 | ((c "{!") (push (- (point) 2) stk)) 685 | ((c "-}") (unless (and stk (not (pop stk))) (err))) 686 | ((c "!}") (if (and stk (setq top (pop stk))) 687 | (or stk (make top)) 688 | (err))) 689 | ((c "?") (progn 690 | (when (and (not stk) (is-lone-questionmark)) 691 | (delete-char -1)(insert "{! !}") 692 | (make (- (point) 5))))))))))) 693 | 694 | (defun agda2-make-goal (p q n) 695 | "Make a goal with number N at

{!...!}. Assume the region is clean." 696 | (flet ((atp (x ps) (add-text-properties x (1+ x) ps))) 697 | (atp p `(category agda2-delim1 agda2-gn ,n)) 698 | (atp (1+ p) '(category agda2-delim2)) 699 | (atp (- q 2) '(category agda2-delim3)) 700 | (atp (1- q) '(category agda2-delim4)) 701 | (agda2-make-goal-B p q n))) 702 | 703 | (defun agda2-make-goal-B (p &optional q n) 704 | "Make a goal at

{!...!} assuming text-properties are already set." 705 | (or q (setq q (+ 2 (text-property-any p (point-max) 'intangible 'right)))) 706 | (or n (setq n (get-text-property p 'agda2-gn))) 707 | (let ((o (make-overlay p q nil t nil))) 708 | (overlay-put o 'agda2-gn n) 709 | (overlay-put o 'face 'highlight) 710 | (overlay-put o 'after-string (propertize (format "%s" n) 'face 'highlight)))) 711 | 712 | (defun agda2-update (old-g new-txt new-gs) 713 | "Update the goal OLD-G and annotate new goals NEW-GS. 714 | NEW-TXT is a string to replace OLD-G, or `'paren', or `'no-paren'" 715 | (interactive) 716 | (multiple-value-bind (p q) (agda2-range-of-goal old-g) 717 | (if (not p) (message "ignoring an update for the missing goal %d" old-g) 718 | (save-excursion 719 | (cond ((stringp new-txt) 720 | (agda2-replace-goal old-g new-txt)) 721 | ((equal new-txt 'paren) 722 | (goto-char (- q 2)) (insert ")") 723 | (goto-char (+ p 2)) (insert "("))) 724 | (agda2-forget-goal old-g 'remove-braces) 725 | (agda2-annotate new-gs p))))) 726 | 727 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 728 | ;;;; Misc 729 | 730 | (defun agda2-process-status () 731 | "Status of `agda2-buffer', or \"no process\"." 732 | (agda2-protect (process-status agda2-process) "no process")) 733 | 734 | (defun agda2-intersperse (sep xs) (interactive) 735 | (let(ys)(while xs (push (pop xs) ys)(push sep ys))(pop ys)(nreverse ys))) 736 | 737 | (defun agda2-goal-Range (o) 738 | "Range of goal overlay O." (interactive) 739 | (format "(Range [Interval %s %s])" 740 | (agda2-mkPos (+ (overlay-start o) 2)) 741 | (agda2-mkPos (- (overlay-end o) 2)))) 742 | 743 | (defun agda2-mkPos (&optional p) 744 | "Position value of P or point." (interactive) 745 | (save-excursion 746 | (if p (goto-char p)) 747 | (format "(Pn \"%s\" %d %d %d)" (buffer-file-name) 748 | (point) (count-lines (point-min) (point)) (1+ (current-column))))) 749 | 750 | (defun agda2-char-quote (c) 751 | "Convert character C to the notation used in Haskell strings. 752 | The non-ASCII characters are actually rendered as 753 | \"\\xNNNN\\&\", i.e. followed by a \"null character\", to avoid 754 | problems if they are followed by digits. ASCII characters (code 755 | points < 128) are converted to singleton strings." 756 | (if (< c 128) 757 | (list c) 758 | ;; FIXME: Why return a list rather than a string? --Stef 759 | (append (format "\\x%x\\&" (encode-char c 'ucs)) nil))) 760 | 761 | (defun agda2-string-quote (s) 762 | "Convert string S into a string representing it in Haskell syntax. 763 | Escape newlines, double quotes, etc.. in the string S, add 764 | surrounding double quotes, and convert non-ASCII characters to the \\xNNNN 765 | notation used in Haskell strings." 766 | (let ((pp-escape-newlines t)) 767 | (mapconcat 'agda2-char-quote (pp-to-string s) ""))) 768 | 769 | (defun agda2-list-quote (strings) 770 | "Convert a list of STRINGS into a string representing it in Haskell syntax." 771 | (concat "[" (mapconcat 'agda2-string-quote strings ", ") "]")) 772 | 773 | (defun agda2-goal-at(pos) 774 | "Return (goal overlay, goal number) at POS, or nil." 775 | (let ((os (and pos (overlays-at pos))) o g) 776 | (while (and os (not(setq g (overlay-get (setq o (pop os)) 'agda2-gn))))) 777 | (if g (list o g)))) 778 | 779 | (defun agda2-goal-overlay (g) 780 | "Return overlay of the goal number G." 781 | (car(agda2-goal-at(text-property-any(point-min)(point-max) 'agda2-gn g)))) 782 | 783 | (defun agda2-range-of-goal (g) 784 | "The range of goal G." 785 | (let ((o (agda2-goal-overlay g))) 786 | (if o (list (overlay-start o) (overlay-end o))))) 787 | 788 | (defun agda2-goto-goal (g) 789 | (let ((p (+ 2 (car (agda2-range-of-goal g))))) 790 | (if p (goto-char p)))) 791 | 792 | (defun agda2-replace-goal (g newtxt) 793 | "Replace the content of goal G with NEWTXT." (interactive) 794 | (save-excursion 795 | (multiple-value-bind (p q) (agda2-range-of-goal g) 796 | (setq p (+ p 2) q (- q 2)) 797 | (let ((indent (and (goto-char p) (current-column)))) 798 | (delete-region p q) (insert newtxt) 799 | (while (re-search-backward "^" p t) 800 | (insert-char ? indent) (backward-char (1+ indent))))))) 801 | 802 | (defun agda2-forget-goal (g &optional remove-braces) 803 | (multiple-value-bind (p q) (agda2-range-of-goal g) 804 | (let ((o (agda2-goal-overlay g))) 805 | (remove-text-properties p q 806 | '(category intangible read-only invisible agda2-gn)) 807 | (when remove-braces 808 | (delete-region (- q 2) q) 809 | (delete-region p (+ p 2))) 810 | (delete-overlay o)))) 811 | 812 | (defun agda2-forget-all-goals () 813 | (let ((p (point-min))) 814 | (while (setq p (next-single-property-change p 'agda2-gn)) 815 | (agda2-forget-goal (get-text-property p 'agda2-gn))))) 816 | 817 | 818 | (defun agda2-decl-beginning () 819 | "Find the beginning point of the declaration containing the point. 820 | To do: dealing with semicolon separated decls." 821 | (interactive) 822 | (save-excursion 823 | (let* ((pEnd (point)) 824 | (pDef (progn (goto-char (point-min)) 825 | (re-search-forward "\\s *" pEnd t))) 826 | (cDef (current-column))) 827 | (while (re-search-forward 828 | "where\\(\\s +\\)\\S \\|^\\(\\s *\\)\\S " pEnd t) 829 | (if (match-end 1) 830 | (setq pDef (goto-char (match-end 1)) 831 | cDef (current-column)) 832 | (goto-char (match-end 2)) 833 | (if (>= cDef (current-column)) 834 | (setq pDef (point) 835 | cDef (current-column)))) 836 | (forward-char)) 837 | (goto-char pDef) 838 | (if (equal (current-word) "mutual") 839 | (or (match-end 2) (match-end 1)) 840 | pDef)))) 841 | 842 | (defun agda2-beginning-of-decl () 843 | (interactive) 844 | (goto-char (agda2-decl-beginning))) 845 | 846 | (defun agda2-no-modified-p (func &rest args) 847 | "Call FUNC without affecting the `buffer-modified-p' flag." 848 | (interactive) 849 | (let ((old-buffer-modified (buffer-modified-p))) 850 | (unwind-protect 851 | (apply func args) 852 | ;; FIXME: Using restore-buffer-modified-p would be slighlty better. 853 | (set-buffer-modified-p old-buffer-modified)))) 854 | 855 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 856 | ;;;; Indentation 857 | 858 | (defun agda2-indent () 859 | "This is what happens when TAB is pressed. 860 | Depends on the setting of `agda2-indentation'." 861 | (interactive) 862 | (cond ((eq agda2-indentation 'haskell) (haskell-indent-cycle)) 863 | ((eq agda2-indentation 'eri) (eri-indent)))) 864 | 865 | (defun agda2-indent-reverse () 866 | "This is what happens when S-TAB is pressed. 867 | Depends on the setting of `agda2-indentation'." 868 | (interactive) 869 | (cond ((eq agda2-indentation 'eri) (eri-indent-reverse)))) 870 | 871 | (defun agda2-indent-setup () 872 | "Set up and start the indentation subsystem. 873 | Depends on the setting of `agda2-indentation'." 874 | (interactive) 875 | (cond ((eq agda2-indentation 'haskell) 876 | (labels ((setl (var val) (set (make-local-variable var) val))) 877 | (setl 'indent-line-function 'haskell-indent-cycle) 878 | (setl 'haskell-indent-off-side-keywords-re 879 | "\\<\\(do\\|let\\|of\\|where\\|sig\\|struct\\)\\>[ \t]*")) 880 | (local-set-key "\177" 'backward-delete-char-untabify) 881 | (set (make-local-variable 'haskell-literate) 882 | (if (string-match "\\.lagda$" (buffer-file-name)) 883 | 'latex)) 884 | (setq haskell-indent-mode t) 885 | (run-hooks 'haskell-indent-hook)))) 886 | 887 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 888 | ;; Comments and paragraphs 889 | 890 | (defun agda2-comments-and-paragraphs-setup nil 891 | "Set up comment and paragraph handling for Agda mode." 892 | 893 | ;; Syntax table setup for comments is done elsewhere. 894 | 895 | ;; Empty lines (all white space according to Emacs) delimit 896 | ;; paragraphs. 897 | (set (make-local-variable 'paragraph-start) "\\s-*$") 898 | (set (make-local-variable 'paragraph-separate) paragraph-start) 899 | 900 | ;; Support for adding/removing comments. 901 | (set (make-local-variable 'comment-padding) " ") 902 | (set (make-local-variable 'comment-start) "--") 903 | 904 | ;; Support for proper filling of text in comments (requires that 905 | ;; Filladapt is activated). 906 | (when (featurep 'filladapt) 907 | (add-to-list (make-local-variable 908 | 'filladapt-token-table) 909 | '("--" agda2-comment)) 910 | (add-to-list (make-local-variable 'filladapt-token-match-table) 911 | '(agda2-comment agda2-comment) t) 912 | (add-to-list (make-local-variable 'filladapt-token-conversion-table) 913 | '(agda2-comment . exact)))) 914 | 915 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 916 | ;; Go to definition site 917 | 918 | (defun agda2-goto-definition-keyboard (&optional other-window) 919 | "Go to the definition site of the name under point (if any). 920 | If this function is invoked with a prefix argument then another window is used 921 | to display the given position." 922 | (interactive "P") 923 | (annotation-goto-indirect (point) other-window)) 924 | 925 | (defun agda2-goto-definition-mouse (ev prefix) 926 | "Go to the definition site of the name clicked on, if any. 927 | Otherwise, yank (see `mouse-yank-at-click')." 928 | (interactive "e\nP") 929 | (let ((pos (posn-point (event-end ev)))) 930 | (if (annotation-goto-possible pos) 931 | (annotation-goto-indirect pos) 932 | ;; FIXME: Shouldn't we use something like 933 | ;; (call-interactively (key-binding ev))? --Stef 934 | (mouse-yank-at-click ev prefix)))) 935 | 936 | (defun agda2-go-back nil 937 | "Go back to the previous position in which 938 | `agda2-goto-definition-keyboard' or `agda2-goto-definition-mouse' was 939 | invoked." 940 | (interactive) 941 | (annotation-go-back)) 942 | 943 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 944 | ;; Implicit arguments 945 | 946 | (defun agda2-display-implicit-arguments (&optional arg) 947 | "Toggle display of implicit arguments. 948 | With prefix argument, turn on display of implicit arguments if 949 | the argument is a positive number, otherwise turn it off." 950 | (interactive "P") 951 | (cond ((eq arg nil) (agda2-go "toggleImplicitArgs")) 952 | ((and (numberp arg) 953 | (> arg 0)) (agda2-go "showImplicitArgs" "True")) 954 | (t (agda2-go "showImplicitArgs" "False")))) 955 | 956 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 957 | ;;;; 958 | 959 | (defun agda2-popup-menu-3 (ev) 960 | "If in a goal, popup the goal menu and call chosen command." 961 | (interactive "e") 962 | (let (choice) 963 | (save-excursion 964 | (and (agda2-goal-at (goto-char (posn-point (event-end ev)))) 965 | (setq choice (x-popup-menu ev agda2-goal-map)) 966 | (call-interactively 967 | (lookup-key agda2-goal-map (apply 'vector choice))))))) 968 | 969 | (provide 'agda2-mode) 970 | ;;; agda2-mode.el ends here 971 | -------------------------------------------------------------------------------- /modes/darcsum/darcsum.el: -------------------------------------------------------------------------------- 1 | ;;; darcsum.el --- a pcl-cvs like interface for managing darcs patches 2 | 3 | ;; Copyright (C) 2004 John Wiegley 4 | ;; Copyright (C) 2005 Christian Neukirchen 5 | ;; Copyright (C) 2005 Free Software Foundation, Inc. 6 | 7 | ;; Author: John Wiegley 8 | ;; Maintainer: Of this fork: Christian Neukirchen 9 | ;; Keywords: completion convenience tools vc 10 | ;; Version: 1.10-chris 11 | ;; location: http://www.newartisans.com/johnw/emacs.html 12 | ;; http://chneukirchen.org/repos/darcsum 13 | 14 | ;; This file is not yet part of GNU Emacs. 15 | 16 | ;; This module is free software; you can redistribute it and/or modify 17 | ;; it under the terms of the GNU General Public License as published 18 | ;; by the Free Software Foundation; either version 2, or (at your 19 | ;; option) any later version. 20 | 21 | ;; This module is distributed in the hope that it will be useful, but 22 | ;; WITHOUT ANY WARRANTY; without even the implied warranty of 23 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 24 | ;; General Public License for more details. 25 | 26 | ;; You should have received a copy of the GNU General Public License 27 | ;; along with GNU Emacs; see the file COPYING. If not, write to the 28 | ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, 29 | ;; Boston, MA 02111-1307, USA. 30 | 31 | ;;; Commentary: 32 | 33 | ;; Load this file and run M-x darcsum-whatsnew. This will display a 34 | ;; pcl-cvs like buffer showing modified files. RET on a file reveals 35 | ;; changes; RET on a directory reveals changes to its files. 36 | ;; 37 | ;; Displayed changes may be recorded with "c", which offers a buffer 38 | ;; for inputting the change name (first line) and long description 39 | ;; (subsequent lines). C-c C-c records the patch. 40 | ;; 41 | ;; If you only want to record a part of your changes, you need to mark 42 | ;; those. If a change is "marked" in the summary buffer with "m" 43 | ;; (done on the change, the file (all changes) or the directory (all 44 | ;; changes in all files)), only marked changes are recorded, 45 | ;; regardless of point. 46 | ;; 47 | ;; Alternatively, if no changes are marked, then only visible changes 48 | ;; are recorded. 49 | ;; 50 | ;; Move changes between buffers with "M", which prompts for a darcsum 51 | ;; buffer to move to (creating one if the buffer doesn't exist). 52 | ;; 53 | ;; "g" forgets everything and resubmits the "whatsnew" command. 54 | ;; Collapsing a file forgets all marks for that file. Only displayed 55 | ;; changes are ever recorded! 56 | ;; 57 | ;; "n" and "p" move among files. "q" kills the buffer. 58 | 59 | ;; TODO (Patches are welcome!): 60 | 61 | ;; - When merging changesets, check the content of change text too 62 | ;; - Better support for moving files 63 | ;; - use --interactive with apply, for applying patches from e-mail 64 | ;; via darcsum 65 | ;; - Better logfile handling 66 | ;; - Interface to darcs replace 67 | ;; - Interface to darcs unrecord 68 | 69 | ;;; Code: 70 | 71 | (eval-when-compile 72 | (require 'cl) 73 | (require 'add-log)) 74 | 75 | ;; Attempt to handle older/other emacs in XEmacs way. 76 | ;; If `line-beginning-position' isn't available, use point-at-bol. 77 | (unless (fboundp 'line-beginning-position) 78 | (defalias 'line-beginning-position 'point-at-bol)) 79 | 80 | (defgroup darcsum nil 81 | "Special support for the Darcs versioning system." 82 | ;; :version "21.4" 83 | :group 'tools 84 | :prefix "darcsum-") 85 | 86 | (defvar darcsum-data nil) 87 | (defvar darcsum-look-for-adds nil) 88 | (defvar darcsum-show-context nil) 89 | (defvar darcsum-pre-ediff-window-configuration nil) 90 | (defvar darcsum-subdirectory ".") 91 | 92 | ;; Make buffer-local variable storing old window configuration, 93 | ;; since "let" bindings die before ediff buffers are killed 94 | (make-variable-buffer-local 'darcsum-pre-ediff-window-configuration) 95 | 96 | (defface darcsum-header-face 97 | '((((class color) (background dark)) 98 | (:foreground "lightyellow" :bold t)) 99 | (((class color) (background light)) 100 | (:foreground "blue4" :bold t)) 101 | (t (:bold t))) 102 | "Face used to highlight directory changes." 103 | :group 'darcsum) 104 | 105 | (defface darcsum-marked-face 106 | '((t (:bold t))) 107 | "Face used to highlight marked changes." 108 | :group 'darcsum) 109 | 110 | (defface darcsum-need-action-face 111 | '((((class color) (background dark)) 112 | (:foreground "orange")) 113 | (((class color) (background light)) 114 | (:foreground "orange")) 115 | (t (:italic t))) 116 | "" 117 | :group 'darcsum) 118 | 119 | (defface darcsum-need-action-marked-face 120 | '((((class color) (background dark)) 121 | (:foreground "orange" :bold t)) 122 | (((class color) (background light)) 123 | (:foreground "orange" :bold t)) 124 | (t (:italic t :bold t))) 125 | "" 126 | :group 'darcsum) 127 | 128 | (defface darcsum-filename-face 129 | '((((class color) (background dark)) 130 | (:foreground "lightblue")) 131 | (((class color) (background light)) 132 | (:foreground "blue4")) 133 | (t ())) 134 | "Face used to highlight file names." 135 | :group 'darcsum) 136 | 137 | (defface darcsum-change-line-face 138 | '((((class color) (background dark)) 139 | (:foreground "grey75" :background "grey25")) 140 | (((class color) (background light)) 141 | (:foreground "grey25" :background "grey75")) 142 | (t (:bold t))) 143 | "Face used to highlight file names." 144 | :group 'darcsum) 145 | 146 | (defface darcsum-whitespace-ateol-face 147 | '((((class color) (background dark)) 148 | (:background "red4")) 149 | (((class color) (background light)) 150 | (:background "red1"))) 151 | "Face used to highlight whitespace at end of line." 152 | :group 'darcsum) 153 | 154 | (defun darcsum-add-props (str &rest props) 155 | (add-text-properties 0 (1- (length str)) (list* props) str) 156 | str) 157 | 158 | (defun darcsum-add-face (str face &optional keymap &rest props) 159 | (when keymap 160 | (when (keymapp keymap) 161 | (setq props (list* 'keymap keymap props))) 162 | (setq props (list* 'mouse-face 'highlight props))) 163 | (add-text-properties 0 (length str) (list* 'face face props) str) 164 | str) 165 | 166 | ;;; Code to work with changesets 167 | 168 | ;; A changeset is an alist of the following form: 169 | ;; 170 | ;; ((PATH (TYPE SELECTED CONTENT...)))) 171 | ;; 172 | ;; where PATH is plain string, but TYPE is of the following 173 | ;; possible formats: 174 | ;; 175 | ;; LINE An integer giving the first line of the hunk 176 | ;; SYMBOL Non-hunk change: 'addfile 'newfile 'rmfile 'binary or 'replace 177 | ;; 178 | ;; SELECTED is a list of flags, 'mark or 'hide symbols. 179 | ;; 180 | ;; Each CONTENT is a string which represents a modification to make to the 181 | ;; file after the starting line. For hunks, each change begins with either a 182 | ;; "+" or "-" to indicate if the line should be removed or added to the 183 | ;; file. 184 | ;; 185 | ;; So, for example, in a buffer with changes visible in report.cc visible 186 | ;; and changes in report.h marked: 187 | ;; 188 | ;; (("./TODO" (addfile (hide))) 189 | ;; ("./report.cc" 190 | ;; (replace nil "[A-Za-z_0-9] indented intended") 191 | ;; (606 nil "- blah" "+ blah" "+ blah") 192 | ;; (620 nil "- blah" "+ blah" "+ blah") 193 | ;; (629 nil "- blah" "+ blah" "+ blah") 194 | ;; (634 nil "- blah" "+ blah" "+ blah") 195 | ;; (641 nil "- blah" "+ blah" "+ blah") 196 | ;; (652 nil "- blah" "+ blah" "+ blah") 197 | ;; (664 nil "- blah" "+ blah" "+ blah")) 198 | ;; ("./report.h" 199 | ;; (115 (mark) "- blah" "+ blah" "+ blah") 200 | ;; (126 (mark) "+")))) 201 | ;; 202 | 203 | (defun darcsum-change-add-flag (change flag) 204 | "Add FLAG on CHANGE." 205 | (if (not (memq flag (cadr change))) 206 | (setcar (cdr change) (cons flag (cadr change))))) 207 | 208 | (defun darcsum-change-remove-flag (change flag) 209 | "Remove FLAG on CHANGE." 210 | (if (memq flag (cadr change)) 211 | (setcar (cdr change) (delq flag (cadr change))))) 212 | 213 | (defun darcsum-change-remove-all-flags (change) 214 | "Remove all flags on CHANGE." 215 | (setcar (cdr change) nil)) 216 | 217 | (defun darcsum-change-toggle-flag (change flag) 218 | "Toggle FLAG on CHANGE." 219 | (if (memq flag (cadr change)) 220 | (setcar (cdr change) (delq flag (cadr change))) 221 | (setcar (cdr change) (cons flag (cadr change))))) 222 | 223 | (defun darcsum-change-mark-p (change) 224 | "Return mark if CHANGE is marked." 225 | (not (null (memq 'mark (cadr change))))) 226 | 227 | (defun darcsum-change-unmark-p (change) 228 | "Return mark if CHANGE is not marked." 229 | (null (memq 'mark (cadr change)))) 230 | 231 | (defun darcsum-change-toggle-mark (change) 232 | "Toggle mark flag on CHANGE." 233 | (darcsum-change-toggle-flag change 'mark)) 234 | 235 | (defun darcsum-change-add-mark (change) 236 | "Add mark flag on CHANGE." 237 | (darcsum-change-add-flag change 'mark)) 238 | 239 | (defun darcsum-change-remove-mark (change) 240 | "Remove mark flag on CHANGE." 241 | (darcsum-change-remove-flag change 'mark)) 242 | 243 | (defun darcsum-change-visible-p (change) 244 | "Return t if CHANGE is visible." 245 | (not (memq 'hide (cadr change)))) 246 | 247 | (defun darcsum-change-toggle-hide (change) 248 | "Toggle hide flag on CHANGE." 249 | (darcsum-change-toggle-flag change 'hide)) 250 | 251 | (defun darcsum-change-add-hide (change) 252 | "Add hide flag on CHANGE." 253 | (darcsum-change-add-flag change 'hide)) 254 | 255 | (defun darcsum-change-remove-hide (change) 256 | "Add hide flag on CHANGE." 257 | (darcsum-change-remove-flag change 'hide)) 258 | 259 | (defun darcsum-changeset-any-p (changeset predicate) 260 | "Return t if PREDICATE is true for any change in CHANGESET." 261 | (catch 'exit 262 | (ignore 263 | (let (file change) 264 | (dolist (file changeset) 265 | (dolist (change (cdr file)) 266 | (if (funcall predicate change) 267 | (throw 'exit t)))))))) 268 | 269 | (defsubst darcsum-changeset-any-marked-p (changeset) 270 | "Return t if CHANGESET has change(s) which have been marked." 271 | (darcsum-changeset-any-p changeset (function darcsum-change-mark-p))) 272 | 273 | (defsubst darcsum-changeset-any-unmarked-p (changeset) 274 | "Return t if CHANGESET has change(s) which have not been marked." 275 | (darcsum-changeset-any-p changeset (function darcsum-change-unmark-p))) 276 | 277 | (defsubst darcsum-changeset-any-visible-p (changeset) 278 | "Return t if CHANGESET has change(s) which are visible." 279 | (darcsum-changeset-any-p changeset (function darcsum-change-visible-p))) 280 | 281 | (defun darcsum-changeset-all-p (changeset predicate) 282 | "Return t if PREDICATE is true for all change in CHANGESET." 283 | (not (catch 'exit 284 | (ignore 285 | (let (file change) 286 | (dolist (file changeset) 287 | (dolist (change (cdr file)) 288 | (if (not (funcall predicate change)) 289 | (throw 'exit t))))))))) 290 | 291 | (defsubst darcsum-changeset-all-marked-p (changeset) 292 | "Return t if all changes in CHANGESET have been marked." 293 | (darcsum-changeset-all-p changeset (function darcsum-change-mark-p))) 294 | 295 | (defsubst darcsum-changeset-all-visible-p (changeset) 296 | "Return t if all changes in CHANGESET are visible." 297 | (darcsum-changeset-all-p changeset (function darcsum-change-visible-p))) 298 | 299 | (defun darcsum-changeset-find (changeset predicate) 300 | "Return changes selected by PREDICATE from CHANGESET." 301 | (let (file change found) 302 | (dolist (file changeset) 303 | (let (changes) 304 | (dolist (change (cdr file)) 305 | (if (funcall predicate change) 306 | (setq changes (cons change changes)))) 307 | (if changes 308 | (setq changes (cons (car file) (nreverse changes)) 309 | found (cons changes found))))) 310 | (nreverse found))) 311 | 312 | (defun darcsum-changeset-find-visible (changeset) 313 | "Return visible changes from CHANGESET." 314 | (darcsum-changeset-find changeset (function darcsum-change-visible-p))) 315 | 316 | (defun darcsum-changeset-find-marked (changeset) 317 | "Return marked changes from CHANGESET." 318 | (darcsum-changeset-find changeset (function darcsum-change-mark-p))) 319 | 320 | (defsubst darcsum-find-change (changeset file line content) 321 | ;; Return change in CHANGESET with matching FILE, LINE and CONTENT. 322 | ;; If CONTENT is 'any, it is ignored. 323 | (let ((change (assoc line (assoc file changeset)))) 324 | (if (or (eq content 'any) 325 | (equal (caddr change) content)) 326 | change))) 327 | 328 | (defconst darcsum-file-change-status-alist 329 | '((addfile . "Added") 330 | (adddir . "Added directory") 331 | (newfile . "New") 332 | (newdir . "New directory") 333 | (rmfile . "Removed") 334 | (rmdir . "Removed directory") 335 | (binary . "Modified binary"))) 336 | 337 | (defun darcsum-file-change-status (change) 338 | "Return file-change-status displayed with CHANGE." 339 | (cdr (assq (car change) darcsum-file-change-status-alist))) 340 | 341 | (defun darcsum-make-temp-file (&optional template) 342 | "Create temporary file. Optional argument TEMPLATE sets the base name. 343 | 344 | The template, if present, is passed to `expand-file-name' to construct a 345 | fully qualified base name. If absent, the string \"_darcs\" is used. 346 | 347 | The function `make-temp-file' is preferred, but if it is not available, 348 | `make-temp-name' is used as a fallback." 349 | (unless template 350 | (setq template "darcsum")) 351 | (unless (file-name-absolute-p template) 352 | (setq template (expand-file-name template "_darcs"))) 353 | (if (fboundp 'make-temp-file) 354 | (make-temp-file template) 355 | ;; make-temp-name generates a unique name when it is called, but 356 | ;; takes no provisions to ensure that it will remain unique. Thus, 357 | ;; there is a race condition before we use the name. This is 358 | ;; probably a bad thing. 359 | (make-temp-name template))) 360 | 361 | (defun darcsum-changeset-has-directory-p (changeset dir) 362 | (and (assoc dir changeset) t)) 363 | 364 | (defun darcsum-apply-to-changes (data func) 365 | (let (file change) 366 | (dolist (file data) 367 | (dolist (change (cdr file)) 368 | (funcall func change))))) 369 | 370 | (defun darcsum-remove-changeset (changeset remove) 371 | "Remove REMOVE from the CHANGESET." 372 | (let (file change) 373 | (dolist (file remove) 374 | (let ((fentry (assoc (car file) changeset))) 375 | (dolist (change (cdr file)) 376 | (setcdr fentry (delete (assoc (car change) (cdr fentry)) 377 | (cdr fentry)))) 378 | (unless (cdr fentry) 379 | (setq changeset (delete fentry changeset)))))) 380 | changeset) 381 | 382 | (defconst darcsum-item-numeric-alist 383 | '((move . -2) 384 | (addfile . -1) 385 | (adddir . -1) 386 | (newfile . -1) 387 | (newdir . -1) 388 | (rmfile . -1) 389 | (rmdir . -1) 390 | (binary . 0) 391 | (replace . 0))) 392 | 393 | (defun darcsum-change-< (l r) 394 | (setq l (car l) 395 | r (car r)) 396 | (< (if (numberp l) l (or (cdr (assq l darcsum-item-numeric-alist)) 0)) 397 | (if (numberp r) r (or (cdr (assq r darcsum-item-numeric-alist)) 0)))) 398 | 399 | (defun darcsum-add-changeset (changeset add) 400 | "Add ADD to CHANGESET." 401 | (let (file fentry change) 402 | (dolist (file add) 403 | (if (setq fentry (assoc (car file) changeset)) 404 | (progn 405 | (dolist (change (cdr file)) 406 | (unless (member change (cdr fentry)) 407 | (nconc fentry (list change)))) 408 | (setcdr fentry (sort (cdr fentry) (function darcsum-change-<)))) 409 | (setq changeset (cons file changeset))))) 410 | (sort changeset)) 411 | 412 | (defun darcsum-merge-changeset (data changeset) 413 | "Merge CHANGESET into the DATA. 414 | 415 | Currently this simply moves 'mark and 'hide from DATA to CHANGESET." 416 | ;;;;;;; TODO: commute new patches 417 | ;;;;;;; (iow, behave properly if lines are added or deleted) 418 | (let (file data-file change data-change) 419 | (dolist (file changeset) 420 | (if (setq data-file (assoc (car file) data)) 421 | (dolist (change (cdr file)) 422 | (let ((data-change (assoc (car change) data-file)) 423 | (item (car data-change))) 424 | (if (cond 425 | ((null item)) 426 | ((eq item 'replace) (equal (cddr change) (cddr data-change))) 427 | ((numberp item) (darcsum-hunk-match (cddr change) (cddr data-change))) 428 | (t t)) 429 | (setcar (cdr change) (car (cdr data-change))))))))) 430 | changeset) 431 | 432 | (defun darcsum-hunk-match (a b) 433 | "Return t if hunks in A and B match (modify same lines)." 434 | (if (equal a b) 435 | t 436 | (while (string-match "^ " (car a)) (setq a (cdr a))) 437 | (while (string-match "^ " (car b)) (setq b (cdr b))) 438 | (while (and a b (string= (car a) (car b))) 439 | (setq a (cdr a) b (cdr b))) 440 | (if (or (null a) (null b) 441 | (string-match "^[+]" (car a)) 442 | (string-match "^[+]" (car b))) 443 | t))) 444 | 445 | (defun darcsum-parse-changeset (&optional pending visible) 446 | "Return the patch in the current buffer as a Lisp changeset." 447 | (when (looking-at "^{") 448 | (forward-line)) 449 | (let ((limit (* 10 (count-lines (point-min) (point-max)))) 450 | data change entry) 451 | (while (and (not (or (eobp) (looking-at "^}"))) 452 | (> limit 0)) 453 | (setq limit (1- limit)) 454 | (cond 455 | ((looking-at "^\\(addfile\\|adddir\\|rmdir\\|move\\|binary\\|rmfile\\|hunk\\|replace\\)\\s-+\\(.+?\\)\\(\\s-+\\([0-9]+\\|.+\\)\\)?$") 456 | (forward-line) 457 | (let* ((item (intern (match-string 1))) 458 | (path (match-string 2)) 459 | (extra (match-string 4)) 460 | lines) 461 | ;; (message (concat "Looking at " (match-string 1))) 462 | (case item 463 | ('hunk 464 | (while (looking-at "^\\([+ -].*\\)") 465 | (setq lines (cons (match-string 1) lines)) 466 | (forward-line)) 467 | (setq item (string-to-number extra) 468 | lines (nreverse lines))) 469 | ('binary 470 | (while (looking-at "^\\(old\\|new\\)hex$") 471 | (forward-line) 472 | (while (looking-at "^\\*") 473 | (forward-line)))) 474 | ('addfile 475 | (if (and (not (eq pending t)) 476 | (null (assoc path pending))) 477 | (setq item 'newfile))) 478 | ('adddir 479 | (if (and (not (eq pending t)) 480 | (null (assoc path pending))) 481 | (setq item 'newdir))) 482 | ('move 483 | (setq lines (list extra))) 484 | ('replace 485 | (setq lines (list extra)))) 486 | (setq change (cons item (cons (if visible nil (list 'hide)) lines)) 487 | fentry (assoc path data)) 488 | (if (null fentry) 489 | (setq data (cons (cons path (list change)) data)) 490 | ;; (message path) 491 | (setcdr fentry (cons change (cdr fentry)))))) 492 | )) 493 | (assert (>= limit 0)) 494 | (dolist (entry data) 495 | (setcdr entry (sort (cdr entry) (function darcsum-change-<)))) 496 | (nreverse data))) 497 | 498 | (defun darcsum-read-changeset (&optional visible) 499 | (let ((pending 500 | (if (file-readable-p "_darcs/patches/pending") 501 | (with-temp-buffer 502 | (insert-file-contents "_darcs/patches/pending") 503 | (darcsum-parse-changeset t visible))))) 504 | (goto-char (point-min)) 505 | (when (looking-at "^What's new in \"\\([^\"]*\\)\":") 506 | (forward-line 2)) 507 | (unless (looking-at "^$") 508 | (darcsum-parse-changeset pending visible)))) 509 | 510 | (defun darcsum-display-changeset (data) 511 | "Display the changeset DATA using a pcl-cvs-like buffer." 512 | ;; Lines starting with number indicates start of hunk 513 | ;; Lines starting with "in directory" indicate directory 514 | ;; Lines starting with \t indicate non-line change 515 | (erase-buffer) 516 | ;;(when (file-readable-p "_darcs/prefs/lastrepo") 517 | ;; (insert "repository : ") 518 | ;; (insert-file-contents "_darcs/prefs/lastrepo") 519 | ;; (goto-char (point-max))) 520 | (insert "Working dir: " default-directory "\n\n\n") 521 | (unless data 522 | (insert "There are no changes to review.\n")) 523 | (let (dir sorted dentry file path status change changes line beg) 524 | (dolist (file data) 525 | (setq path (car file) 526 | dir (if (memq (caadr file) '(adddir rmdir newdir)) path 527 | (directory-file-name (file-name-directory path))) 528 | dentry (assoc dir sorted)) 529 | (if dentry 530 | (setcdr dentry (cons file (cdr dentry))) 531 | (setq sorted (cons (cons dir (list file)) sorted)))) 532 | (setq sorted (sort sorted (function (lambda (a b) 533 | (string-lessp (car a) (car b)))))) 534 | (dolist (dentry sorted) 535 | (setq dir (car dentry) 536 | data (nreverse (cdr dentry)) 537 | beg (point)) 538 | (insert "in directory " 539 | (darcsum-add-face dir 'darcsum-header-face t) 540 | ":\n") 541 | (add-text-properties beg (point) 542 | (list 543 | 'darcsum-line-type 'dir 544 | 'darcsum-line-path dir 545 | 'darcsum-line-change data)) 546 | (dolist (file data) 547 | (setq path (car file) 548 | changes (cdr file) 549 | status nil) 550 | (while changes 551 | (setq change (car changes) 552 | item (car change) 553 | marked (darcsum-change-mark-p change) 554 | visible (darcsum-change-visible-p change) 555 | beg (point)) 556 | (cond 557 | ((eq item 'move) 558 | (darcsum-insert-file-line "Moved" path " -> " visible marked) 559 | (insert (darcsum-add-face (caddr change) 'darcsum-filename-face t) 560 | ?\n)) 561 | ((memq item '(addfile adddir rmfile rmdir newfile newdir binary)) 562 | (setq status (darcsum-file-change-status change)) 563 | (darcsum-insert-file-line status path "\n" 564 | visible marked 'file changes) 565 | (setq changes nil ; don't show other changes 566 | beg (point))) 567 | ((eq item 'replace) 568 | (unless status 569 | (setq status (darcsum-insert-file-line "Modified" path "\n" 570 | nil marked 'file changes) 571 | beg (point))) 572 | (if visible 573 | (insert "\t " 574 | (if marked 575 | (darcsum-add-face 576 | (format "%24s %s" "replace " (caddr change)) 577 | 'darcsum-marked-face t) 578 | (format "%24s %s" "replace " (caddr change))) 579 | ?\n))) 580 | ((numberp item) 581 | (unless status 582 | (setq status (darcsum-insert-file-line "Modified" path "\n" 583 | nil marked 'file changes) 584 | beg (point))) 585 | (unless (not visible) 586 | (insert 587 | (darcsum-add-face 588 | (format "%-10d" (car change)) 'darcsum-change-line-face t) 589 | ?\n) 590 | (dolist (line (cddr change)) 591 | (string-match "[ \t]*$" line 1) 592 | (let ((nws (substring line 0 (match-beginning 0))) 593 | (ws (substring line (match-beginning 0)))) 594 | (insert 595 | (if marked 596 | (darcsum-add-face nws 'darcsum-marked-face t) 597 | nws) 598 | (darcsum-add-face ws 'darcsum-whitespace-ateol-face t) 599 | ?\n)))))) 600 | (if (/= beg (point)) 601 | (add-text-properties beg (point) 602 | (list 'darcsum-line-type 'change 603 | 'darcsum-line-path path 604 | 'darcsum-line-change 605 | (list (list path change))))) 606 | (setq changes (cdr changes)))))) 607 | (insert " 608 | --------------------- End ---------------------\n")) 609 | 610 | (defun darcsum-insert-file-line (title path end visible marked 611 | &optional line-type changes) 612 | "Insert per-file line into buffer" 613 | (let ((begin (point))) 614 | (if (and marked changes) 615 | (setq marked (darcsum-changeset-all-marked-p 616 | (list (cons path changes))))) 617 | (insert 618 | "\t " 619 | (if visible 620 | (darcsum-add-face " * " 'darcsum-change-line-face t) 621 | " ") 622 | " " 623 | (darcsum-add-face (format "%-24s" title) 624 | (if marked 625 | 'darcsum-need-action-marked-face 626 | 'darcsum-need-action-face) t) 627 | (darcsum-add-face (file-name-nondirectory path) 'darcsum-filename-face t) 628 | end) 629 | (if line-type 630 | (add-text-properties beg (point) 631 | (list 'darcsum-line-type 'file 632 | 'darcsum-line-path path 633 | 'darcsum-line-change 634 | (list (cons path changes)))))) 635 | title) 636 | 637 | (defsubst darcsum-get-line-type (&optional position) 638 | "Get darcsum line type at point or at the given POSITION." 639 | (get-text-property (or position (point)) 'darcsum-line-type)) 640 | 641 | ;;; Code to determine the current changeset in darcsum-mode 642 | 643 | (defun darcsum-changeset-at-point (&optional invisible-too) 644 | "Return changeset at current point" 645 | (let ((data (get-text-property (point) 'darcsum-line-change))) 646 | (if invisible-too 647 | data 648 | (darcsum-changeset-find-visible data)))) 649 | 650 | (defun darcsum-selected-changeset (&optional all-visible) 651 | "Return the currently selected changeset. 652 | 653 | If marks are active, always returned the marked changes. 654 | Otherwise, return the changes related to point, unless ALL-VISIBLE is 655 | non-nil, in which case return all visible changes." 656 | (cond 657 | ((darcsum-changeset-any-marked-p darcsum-data) 658 | (darcsum-changeset-find-marked darcsum-data)) 659 | (all-visible 660 | (darcsum-changeset-find-visible darcsum-data)) 661 | (t 662 | (darcsum-changeset-at-point 'invisible-too)))) 663 | 664 | ;;; Code to record the current changeset 665 | 666 | ;; If there are any marked changes, these are what get recorded. 667 | ;; Otherwise, all *visible* changes are recorded. 668 | 669 | (defcustom darcsum-program "darcs" 670 | "*The program name which darcsum will use to invoke darcs." 671 | :type 'string 672 | :group 'darcsum) 673 | 674 | (defcustom darcsum-default-expanded nil 675 | "*Non-nil means the *darcsum* buffer will be expanded by default." 676 | :type 'boolean 677 | :group 'darcsum) 678 | 679 | (defvar darcsum-output-environment 680 | (list 681 | "DARCS_DONT_ESCAPE_TRAILING_SPACES=1" 682 | "DARCS_DONT_COLOR=1" 683 | "DARCS_DONT_ESCAPE_TRAILING_CR=1") 684 | "The environment variables to turn off highlighting.") 685 | 686 | (defvar darcsum-environment 687 | nil 688 | "*The extra environment variables for darcs.") 689 | 690 | (defvar darcsum-process-arg nil) 691 | (defvar darcsum-parent-buffer nil) 692 | (defvar darcsum-changeset-to-record nil) 693 | (defvar darcsum-logfile) 694 | 695 | (defvar darcsum-window-configuration-temp nil) 696 | 697 | (defsubst darcsum-remember-window-configuration () 698 | (setq darcsum-window-configuration-temp (list (current-window-configuration) 699 | (point-marker)))) 700 | (defsubst darcsum-recall-window-configuration () 701 | (if darcsum-window-configuration-temp 702 | (progn 703 | (set-window-configuration (car darcsum-window-configuration-temp)) 704 | (goto-char (cadr darcsum-window-configuration-temp))) 705 | (error "No window configuration to restore."))) 706 | 707 | (defsubst darcsum-changes-handled () 708 | (if (buffer-live-p darcsum-parent-buffer) 709 | (let ((changeset darcsum-changeset-to-record)) 710 | (with-current-buffer darcsum-parent-buffer 711 | (setq darcsum-data 712 | (darcsum-remove-changeset darcsum-data changeset)) 713 | (darcsum-refresh))))) 714 | 715 | (defvar darcsum-darcs-2-options 'not-set) 716 | 717 | (defun darcsum-start-process (subcommand args 718 | &optional name value &rest localize) 719 | "Start darcs process." 720 | (if (eq darcsum-darcs-2-options 'not-set) 721 | ;; Check version and set proper darcsum-darcs-2-options 722 | (with-temp-buffer 723 | (call-process darcsum-program nil t nil "--version") 724 | (goto-char (point-min)) 725 | (setq darcsum-darcs-2-options 726 | (if (looking-at "2[.]") (list "--quiet"))))) 727 | (let* 728 | ((buf (generate-new-buffer (format " *darcs %s*" subcommand))) 729 | (process-environment 730 | (append darcsum-environment 731 | darcsum-output-environment 732 | process-environment)) 733 | (process-connection-type nil) 734 | (proc (apply 'start-process "darcs" 735 | buf darcsum-program subcommand 736 | (append darcsum-darcs-2-options args)))) 737 | (set-process-sentinel proc 'darcsum-process-sentinel) 738 | (set-process-filter proc 'darcsum-process-filter) 739 | (with-current-buffer buf 740 | (while name 741 | (set (make-local-variable name) value) 742 | (setq name (car localize) 743 | value (cadr localize) 744 | localize (cddr localize)))) 745 | proc)) 746 | 747 | (defun darcsum-process-sentinel (proc string) 748 | (if (buffer-live-p (process-buffer proc)) 749 | (with-current-buffer (process-buffer proc) 750 | (save-excursion 751 | (goto-char (point-min)) 752 | (cond 753 | ((looking-at "\n*\\(Couldn't get lock [^\n]*\\)") 754 | (let ((waiting (match-string 1))) 755 | (message waiting) 756 | (kill-buffer (current-buffer)))) 757 | ((string-match "^exited abnormally" string) 758 | (message string))))))) 759 | 760 | (defun darcsum-process-filter (proc string) 761 | (with-current-buffer (process-buffer proc) 762 | (let ((moving (= (point) (process-mark proc)))) 763 | (save-excursion 764 | ;; Insert the text, advancing the process marker. 765 | (goto-char (process-mark proc)) 766 | (insert string) 767 | (set-marker (process-mark proc) (point))) 768 | (if moving (goto-char (process-mark proc)))) 769 | (save-excursion 770 | (goto-char (point-min)) 771 | 772 | (if (looking-at "\n*Skipped \\(record\\|add\\|revert\\) of [0-9]+ patch\\(es\\)?\\.\n") 773 | (delete-region (point-min) (match-end 0))) 774 | 775 | (cond 776 | ((looking-at "\n*Finished \\(recording\\|amending\\) patch") 777 | (message "Changes recorded.") 778 | (darcsum-changes-handled) 779 | (when darcsum-logfile (delete-file darcsum-logfile)) 780 | (kill-buffer (current-buffer))) 781 | ((looking-at "\n*Ok, if you don't want to \\(record\\|amend\\) anything") 782 | (message "No changes recorded.") 783 | (when darcsum-logfile (delete-file darcsum-logfile)) 784 | (kill-buffer (current-buffer))) 785 | 786 | ((looking-at "\n*What is the target email address") 787 | (process-send-string proc darcsum-process-arg) 788 | (delete-region (point-min) (point-max))) 789 | ((looking-at "\n*Successfully sent patch bundle") 790 | (message "Changes sent to `%s'." darcsum-process-arg) 791 | (kill-buffer (current-buffer))) 792 | ((looking-at "\n*You don't want to send any patches") 793 | (message "No changes sent.") 794 | (kill-buffer (current-buffer))) 795 | 796 | ((looking-at "\n*Do you really want to .+\\? ") ;; Should the last whitespace be there? 797 | (process-send-string proc "y\n") 798 | (delete-region (point-min) (point-max))) 799 | ((looking-at "\n*Finished reverting.") 800 | (message "Changes reverted.") 801 | (darcsum-changes-handled) 802 | (kill-buffer (current-buffer))) 803 | ((looking-at "\n*If you don't want to revert") 804 | (message "No changes reverted.") 805 | (kill-buffer (current-buffer))) 806 | 807 | ((looking-at "\n*\\(Waiting for lock.*\\)\n+") 808 | (let ((waiting (match-string 1))) 809 | (message waiting) 810 | (delete-region (point-min) (match-end 0)))) 811 | 812 | ((looking-at "\n*\\(Couldn't get lock.*\\)\n*") 813 | (let ((waiting (match-string 1))) 814 | (message waiting) 815 | (kill-buffer (current-buffer)))) 816 | 817 | ((looking-at "\\(.*\n\\)*Shall I amend this patch\\?.*") 818 | (process-send-string proc "y") 819 | (delete-region (point-min) (match-end 0))) 820 | 821 | ((looking-at "\n*Darcs needs to know what name") 822 | (let* ((default-mail (concat user-full-name 823 | " <" user-mail-address ">")) 824 | (enable-recursive-minibuffers t) 825 | (mail-address (read-string 826 | (format 827 | "What is your email address? (default %s) " 828 | default-mail) 829 | nil nil default-mail))) 830 | (process-send-string proc mail-address) 831 | (process-send-string proc "\n")) 832 | (re-search-forward "What is your email address\\?.*") 833 | (delete-region (point-min) (point))) 834 | 835 | ((looking-at "\n*\\(move\\|addfile\\|adddir\\|binary\\|rmfile\\|rmdir\\|hunk\\|replace\\)\\s-+\\(.+?\\)\\(\\s-+\\([0-9]+\\)?\\)?\\( \\(.+\\)\\)?$") 836 | (let* ((kind (intern (match-string 1))) 837 | (path (match-string 2)) 838 | (start-line (match-string 4)) 839 | (extra (match-string 6)) 840 | (content 'any)) 841 | (goto-char (match-end 0)) 842 | (forward-line) 843 | (case kind 844 | ('hunk (setq kind (string-to-number start-line))) 845 | ('move (setq content extra)) 846 | ('replace (setq content extra))) 847 | (while (looking-at "^\\([+-].*\\)") 848 | (forward-line)) 849 | (when (looking-at 850 | "^Shall I \\(record\\|send\\|revert\\|add\\) this \\(patch\\|change\\)\\?.+[]:] ") 851 | (let ((end (match-end 0)) 852 | (reply (darcsum-find-change 853 | darcsum-changeset-to-record 854 | path kind content))) 855 | ;; (message (concat (if reply "Do " "Skip ") (match-string 1) " to " path)) 856 | (process-send-string proc (if reply "y" "n")) 857 | (delete-region (point-min) end))))) 858 | 859 | ((looking-at "\n*\\(move\\).+") 860 | (goto-char (match-end 0)) 861 | (forward-line) 862 | (when (looking-at 863 | "^Shall I \\(record\\|send\\|revert\\|add\\) this \\(patch\\|change\\)\\?.+[]:] ") 864 | (let ((end (match-end 0))) 865 | (process-send-string proc "n") 866 | (delete-region (point-min) end)))))))) 867 | 868 | (defun darcsum-really-record () 869 | (interactive) 870 | (let ((tempfile (darcsum-make-temp-file "darcsum")) 871 | (parent-buf darcsum-parent-buffer) 872 | (changeset darcsum-changeset-to-record)) 873 | (save-excursion 874 | (goto-char (point-max)) 875 | (unless (bolp) 876 | (insert ?\n)) 877 | (goto-char (point-min)) 878 | (when (looking-at "^\\s-*$") 879 | (error "No record description entered"))) 880 | (write-region (point-min) (point-max) tempfile) 881 | (kill-buffer (current-buffer)) 882 | (darcsum-recall-window-configuration) 883 | (message "Recording changes...") 884 | ;;;;;;;; TODO: optionally pass in e.g. --no-test somehow 885 | (darcsum-start-process 886 | "record" (list "--logfile" tempfile) 887 | 'darcsum-logfile tempfile 888 | 'darcsum-changeset-to-record changeset 889 | 'darcsum-parent-buffer parent-buf))) 890 | 891 | (defun darcsum-record () 892 | "Record selected changeset. 893 | Note that only changes selected for recording are actually recorded. 894 | If some changes are marked \(with \ 895 | \\\\[darcsum-toggle-mark]\), \ 896 | then only those changes are recorded. 897 | Otherwise, only changes which are selected to be displayed in the buffer 898 | \(with \\\\[darcsum-toggle]\) are recorded." 899 | (interactive) 900 | (darcsum-remember-window-configuration) 901 | (let ((parent-buf (current-buffer)) 902 | (changeset (darcsum-selected-changeset t)) 903 | (buf)) 904 | (if (null changeset) 905 | (error "No changes are selected")) 906 | (if (darcsum-changeset-any-p changeset 907 | (function 908 | (lambda (change) 909 | (memq (car change) '(newdir newfile))))) 910 | (error "You have to add new directories and files first.")) 911 | (switch-to-buffer-other-window (setq buf (get-buffer-create "*darcs comment*"))) 912 | (if (fboundp 'log-edit) 913 | ;; TODO: add SETUP (nil?) and LISTFUN arguments? See also `vc-log-edit' 914 | (log-edit #'darcsum-really-record) 915 | (darcsum-comment-mode) ) 916 | (set (make-local-variable 'darcsum-changeset-to-record) changeset) 917 | (set (make-local-variable 'darcsum-parent-buffer) parent-buf) 918 | (message 919 | "Title of change on first line, long comment after. \ 920 | C-c C-c to record.") 921 | (run-hooks 'darcsum-comment-hook))) 922 | 923 | (defun darcsum-send (recipient) 924 | "Send selected changeset via email." 925 | (interactive "sSend changes to: ") 926 | (message "Sending changes...") 927 | (darcsum-start-process 928 | "send" (list) 929 | 'darcsum-changeset-to-record (darcsum-selected-changeset t) 930 | 'darcsum-parent-buffer (current-buffer) 931 | 'darcsum-process-arg recipient)) 932 | 933 | (defun darcsum-changes (&optional how-many) 934 | "Show the changes in another buffer. Optional argument HOW-MANY limits 935 | the number of changes shown, counting from the most recent changes." 936 | (interactive "P") 937 | (let ((proc (darcsum-start-process 938 | "changes" (if how-many 939 | (list "--last" (number-to-string how-many)) 940 | (list)) 941 | 'darcsum-parent-buffer (current-buffer)))) 942 | (set-process-filter proc nil) 943 | (set-process-sentinel proc 'darcsum-changes-sentinel) 944 | (switch-to-buffer-other-window (process-buffer proc)) 945 | (process-buffer proc))) 946 | 947 | (defun darcsum-changes-sentinel (process event) 948 | (with-current-buffer (process-buffer process) 949 | (darcsum-changes-mode) 950 | (goto-char (point-min)))) 951 | 952 | (defun darcsum-query-manifest () 953 | "List the version-controlled files in the working copy." 954 | (interactive) 955 | (let ((proc (darcsum-start-process 956 | "query" '("manifest") 957 | 'darcsum-parent-buffer (current-buffer)))) 958 | (set-process-filter proc nil) 959 | (set-process-sentinel proc 'darcsum-query-manifest-sentinel) 960 | (switch-to-buffer-other-window (process-buffer proc)) 961 | (process-buffer proc))) 962 | 963 | (defun darcsum-query-manifest-sentinel (process event) 964 | (with-current-buffer (process-buffer process) 965 | (setq buffer-read-only t) 966 | (darcsum-query-mode) 967 | (goto-char (point-min)))) 968 | 969 | (defcustom darcsum-amend-confirmation-function #'darcsum-amend-confirmation 970 | "*Function to invoke for confirming an amend operation. 971 | 972 | The function receives a prompt string as its sole argument; the expectation 973 | is that it would display this string to the user, and prompt for a response. 974 | 975 | When the function is invoked, the current buffer is a temporary history 976 | buffer displaying information about the patch which is about to be amended, 977 | and a warning about the possible problems committing this change could cause. 978 | 979 | If the function returns nil, `darcsum-amend' will not carry out the 980 | amend operation. 981 | 982 | Setting this function to nil will disable the confirmation logic altogether; 983 | however, this is strongly discouraged. 984 | 985 | Amending a shared repository can be dangerous; see the Darcs manual 986 | for details." 987 | :type '(choice (const :tag "darcsum-amend-confirmation (default)" 988 | #'darcsum-amend-confirmation) 989 | (const :tag "Off (strongly discouraged)" nil) 990 | function) 991 | :group 'darcsum) 992 | 993 | (defun darcsum-amend-confirmation (prompt) 994 | "The default confirmation function for `darcsum-amend-confirmation-function'; 995 | pauses for two seconds, then invokes `yes-or-no-p'." 996 | (sit-for 2) 997 | (yes-or-no-p prompt) ) 998 | 999 | (defun darcsum-amend () 1000 | "Amend last patch with selected changeset." 1001 | (interactive) 1002 | (let ((changeset (darcsum-selected-changeset t)) 1003 | (parent-buffer (current-buffer))) 1004 | (if (> (length changeset) 0) 1005 | (let ((history-buffer (darcsum-changes 1)) 1006 | amend point) 1007 | (unwind-protect 1008 | (with-current-buffer history-buffer 1009 | (setq point (point-max)) 1010 | (goto-char point) 1011 | (insert " 1012 | WARNINGS: You should ONLY use amend-record on patches which only exist in 1013 | a single repository! Also, running amend-record while another user is 1014 | pulling from the same repository may cause repository corruption.\n") 1015 | (goto-char point) 1016 | (setq 1017 | amend 1018 | ;; If darcsum-amend-confirmation-function is nil, don't prompt 1019 | (or 1020 | (not (functionp darcsum-amend-confirmation-function)) 1021 | (funcall darcsum-amend-confirmation-function 1022 | "Amend this latest changeset? (see WARNINGS) ") )) ) 1023 | (kill-buffer history-buffer)) 1024 | (when amend 1025 | (darcsum-start-process 1026 | "amend" (list) 1027 | 'darcsum-logfile nil 1028 | 'darcsum-changeset-to-record changeset 1029 | 'darcsum-parent-buffer parent-buffer))) 1030 | (message "You need to select something first")))) 1031 | 1032 | (defun darcsum-revert () 1033 | "Revert selected changeset." 1034 | (interactive) 1035 | (when (yes-or-no-p "Really revert these changes? ") 1036 | (message "Reverting changes...") 1037 | (darcsum-start-process 1038 | "revert" (list) 1039 | 'darcsum-changeset-to-record (darcsum-selected-changeset t) 1040 | 'darcsum-parent-buffer (current-buffer)))) 1041 | 1042 | (defvar darcsum-comment-mode-map 1043 | (let ((map (make-sparse-keymap))) 1044 | (define-key map "\C-x\C-s" 'darcsum-really-record) 1045 | (define-key map "\C-c\C-c" 'darcsum-really-record) 1046 | map)) 1047 | 1048 | (defun darcsum-kill-ancillary-buffer () 1049 | "Kill an ancillary buffer called by darcsum." 1050 | (interactive) 1051 | (kill-this-buffer) 1052 | (delete-window)) 1053 | 1054 | (defun darcsum-changes-mode-next-comment (&optional n) 1055 | "Move to the next comment. 1056 | 1057 | If called with a positive argument then move N comments forward." 1058 | (interactive "p") 1059 | (if (and n (< 0 n)) 1060 | (let ((comment-start-regexp "^[A-Z][a-z]\\{2\\} [A-Z][a-z]\\{2\\}.*$")) 1061 | (when (looking-at comment-start-regexp) 1062 | (forward-line 1)) 1063 | (let ((next (re-search-forward comment-start-regexp 1064 | (point-max) t (or n 1)))) 1065 | (if next 1066 | (goto-char (point-at-bol)) 1067 | (message "No earlier changes")))) 1068 | (darcsum-changes-mode-previous-comment n))) 1069 | 1070 | (defun darcsum-new-buffer (&optional subdir) 1071 | "Generate new darcsum buffer. Optional argument SUBDIR selects subdirectory." 1072 | (generate-new-buffer 1073 | (concat "*darcs " 1074 | (file-name-nondirectory 1075 | (directory-file-name 1076 | (file-name-directory default-directory))) 1077 | (when subdir "/") 1078 | (when subdir 1079 | (if (file-name-absolute-p subdir) 1080 | (file-relative-name subdir) 1081 | subdir)) 1082 | "*"))) 1083 | 1084 | (defun darcsum-changes-mode-previous-comment (&optional n) 1085 | "Move to the previous comment. 1086 | 1087 | If called with a positive argument then move N comments backward." 1088 | (interactive "p") 1089 | (when (and n (< n 0)) 1090 | (error "To move forward call `darcsum-changes-mode-next-comment' instead")) 1091 | (let ((comment-start-regexp "^[A-Z][a-z]\\{2\\} [A-Z][a-z]\\{2\\}.*$")) 1092 | (when (looking-at comment-start-regexp) 1093 | (forward-line -1)) 1094 | (let ((next (re-search-backward comment-start-regexp 1095 | (point-min) t (or n 1)))) 1096 | (if next 1097 | (goto-char (point-at-bol)) 1098 | (message "No later changes"))))) 1099 | 1100 | (defun darcsum-query-kill-buffer () 1101 | (interactive) 1102 | (kill-this-buffer) 1103 | (delete-window)) 1104 | 1105 | (defvar darcsum-query-mode-map 1106 | (let ((map (make-sparse-keymap))) 1107 | (define-key map "q" 'darcsum-query-kill-buffer) 1108 | map)) 1109 | 1110 | (defvar darcsum-changes-mode-map 1111 | (let ((map (make-sparse-keymap))) 1112 | (define-key map "q" 'darcsum-kill-ancillary-buffer) 1113 | (define-key map "n" 'darcsum-changes-mode-next-comment) 1114 | (define-key map "p" 'darcsum-changes-mode-previous-comment) 1115 | map)) 1116 | 1117 | (define-derived-mode darcsum-comment-mode indented-text-mode "Darcs Summary" 1118 | "Major mode for output from \\\\[darcsum-comment]. 1119 | 1120 | \\{darcsum-comment-mode-map}" 1121 | :group 'darcsum 1122 | (setq truncate-lines t)) 1123 | 1124 | (define-derived-mode darcsum-query-mode indented-text-mode "Darcs Query" 1125 | "Major mode for output from \\\\[darcsum-query-manifest]. 1126 | 1127 | \\{darcsum-query-mode-map}" 1128 | :group 'darcsum 1129 | (setq truncate-lines t)) 1130 | 1131 | (define-derived-mode darcsum-changes-mode indented-text-mode "Darcs Changes" 1132 | "Major mode for output from \\\\[darcsum-changes]. 1133 | 1134 | \\{darcsum-changes-mode-map}" 1135 | :group 'darcsum 1136 | (setq truncate-lines nil) 1137 | (setq buffer-read-only t)) 1138 | 1139 | ;;; Major Mode 1140 | 1141 | (defun darcsum-check-darcsum-mode () 1142 | (unless (eq major-mode 'darcsum-mode) 1143 | (error "Not in a darcsum-mode"))) 1144 | 1145 | (defun darcsum-reposition () 1146 | (unless (null (darcsum-get-line-type)) 1147 | (goto-char (line-beginning-position)) 1148 | (cond 1149 | ((looking-at "in directory") (forward-char 13)) 1150 | ((looking-at "\t") (forward-char 31)) ; at column 38 1151 | ))) 1152 | 1153 | (defsubst darcsum-other-buffer (other-buffer) 1154 | (let ((buf (or other-buffer (darcsum-new-buffer)))) 1155 | (with-current-buffer buf 1156 | (unless (eq major-mode 'darcsum-mode) 1157 | (darcsum-mode)) 1158 | (current-buffer)))) 1159 | 1160 | (defun darcsum-move (other-buffer) 1161 | "Move the selected changeset to another darcsum buffer OTHER-BUFFER. 1162 | 1163 | In interactive mode, prompts for the name of a buffer to move the changeset to. 1164 | 1165 | Changesets may be moved around in different buffers, to ease 1166 | the collection of changes to record in a single darcs patch." 1167 | (interactive "BMove change to (RET creates new patch): ") 1168 | (let ((buf (darcsum-other-buffer other-buffer)) 1169 | (changeset (darcsum-selected-changeset)) 1170 | (inhibit-redisplay t)) 1171 | (setq darcsum-data 1172 | (darcsum-remove-changeset darcsum-data changeset)) 1173 | (with-current-buffer buf 1174 | (darcsum-apply-to-changes changeset 'darcsum-change-remove-all-flags) 1175 | (setq darcsum-data (darcsum-add-changeset darcsum-data changeset)) 1176 | (darcsum-refresh))) 1177 | (darcsum-refresh)) 1178 | 1179 | (defun darcsum-find-file (&optional other view) 1180 | "Open the selected entry. 1181 | With a prefix OTHER, open the buffer in another window. 1182 | If OTHER is 'dont-select, don't select the buffer. 1183 | VIEW non-nil means open in View mode." 1184 | (interactive "P") 1185 | (let ((file (darcsum-path (point))) 1186 | (start (point-at-bol)) 1187 | (change-line 1188 | (and (eq 'change (darcsum-get-line-type)) 1189 | (caadar (darcsum-changeset-at-point t))))) 1190 | (if (numberp change-line) 1191 | (save-excursion 1192 | (goto-char start) 1193 | (cond 1194 | ((looking-at " ") ; We were in context 1195 | (while (looking-at " ") (forward-line)) 1196 | (if (looking-at "[-+]") ; ..before change 1197 | (setq change-line (- change-line (count-lines start (point)))) 1198 | (goto-char start) ; ...after change 1199 | (while (looking-at " ") 1200 | (forward-line -1)) 1201 | (setq change-line (+ change-line -1 (count-lines (point) start))))) 1202 | ((looking-at "[+]") 1203 | (while (looking-at "[+]") 1204 | (forward-line -1)) 1205 | (setq change-line (+ change-line -1 (count-lines (point) start))))))) 1206 | (with-current-buffer 1207 | (cond ((eq other 'dont-select) 1208 | (find-file-noselect file)) 1209 | ((and other view) 1210 | (view-file-other-window file)) 1211 | (view (view-file file)) 1212 | (other (find-file-other-window file)) 1213 | (t (find-file file))) 1214 | (if (numberp change-line) 1215 | (goto-line change-line)) 1216 | (display-buffer (current-buffer)) 1217 | (recenter '(4))))) 1218 | 1219 | (defun darcsum-find-file-other-window () 1220 | "Select a buffer containing the file with current change in another window" 1221 | "possibly moving point to the change's location." 1222 | (interactive) 1223 | (darcsum-check-darcsum-mode) 1224 | (darcsum-find-file t)) 1225 | 1226 | (defun darcsum-goto () 1227 | "Select a buffer containing the file with current change in another window" 1228 | "possibly moving point to the change's location." 1229 | (interactive) 1230 | (darcsum-check-darcsum-mode) 1231 | (darcsum-find-file t)) 1232 | 1233 | (defun darcsum-display-change () 1234 | "Display a buffer containing the current change in another window." 1235 | (interactive) 1236 | (darcsum-check-darcsum-mode) 1237 | (darcsum-find-file 'dont-select)) 1238 | 1239 | (defun darcsum-toggle-context () 1240 | (interactive) 1241 | (darcsum-check-darcsum-mode) 1242 | (setq darcsum-show-context (not darcsum-show-context)) 1243 | (darcsum-redo)) 1244 | 1245 | (defun darcsum-toggle-mark () 1246 | "Toggle mark on current changeset. 1247 | 1248 | Marked changesets have priority over simply activated ones regarding 1249 | the selection of changesets to commit." 1250 | (interactive) 1251 | (darcsum-check-darcsum-mode) 1252 | (let ((changeset (darcsum-changeset-at-point t))) 1253 | (darcsum-apply-to-changes changeset 'darcsum-change-toggle-mark)) 1254 | (darcsum-refresh)) 1255 | 1256 | (defun darcsum-mouse-toggle-mark () 1257 | "Move point to mouse and toggle mark on changeset." 1258 | (interactive) 1259 | (unless (not current-mouse-event) 1260 | (mouse-set-point current-mouse-event) 1261 | (darcsum-toggle-mark))) 1262 | 1263 | (defun darcsum-show () 1264 | "Activate the current changeset." 1265 | (interactive) 1266 | (darcsum-check-darcsum-mode) 1267 | (let ((changeset (darcsum-changeset-at-point t))) 1268 | (darcsum-apply-to-changes changeset 'darcsum-change-remove-hide)) 1269 | (darcsum-refresh)) 1270 | 1271 | (defun darcsum-toggle () 1272 | "Toggle the activation of the current changeset. 1273 | 1274 | The activation of a changeset exposes the associated change, and selects 1275 | it for later commit." 1276 | (interactive) 1277 | (darcsum-check-darcsum-mode) 1278 | ;;;;;;;; TODO: easier to expose a hunk which was made invisible by mistake 1279 | (let ((changeset (darcsum-changeset-at-point t))) 1280 | (if (darcsum-changeset-any-visible-p changeset) 1281 | (darcsum-apply-to-changes changeset 'darcsum-change-add-hide) 1282 | (darcsum-apply-to-changes changeset 'darcsum-change-toggle-hide))) 1283 | (darcsum-refresh)) 1284 | 1285 | (defun darcsum-refresh (&optional line) 1286 | "Refresh the visualization of the changesets. 1287 | 1288 | If LINE is not nil, move to LINE. Otherwise, stay on current line." 1289 | (interactive) 1290 | (darcsum-check-darcsum-mode) 1291 | (let ((inhibit-redisplay t)) 1292 | (unless line 1293 | (setq line (count-lines (point-min) (point-at-bol)))) 1294 | (darcsum-display-changeset darcsum-data) 1295 | (goto-char (point-min)) 1296 | (forward-line line) 1297 | (darcsum-reposition))) 1298 | 1299 | (defun darcsum-line-is (sort) 1300 | (save-excursion 1301 | (beginning-of-line) 1302 | (let ((type (darcsum-get-line-type))) 1303 | (case sort 1304 | ('new (and (eq 'file type) (looking-at " +New"))) 1305 | ('modified (or (and (eq 'file type) (looking-at "\\s-+Modified")) 1306 | (eq 'change type))) 1307 | ('file (eq 'file type)) 1308 | ('change (eq 'change type)) 1309 | ('marked 1310 | (memq (get-text-property (point) 'face) 1311 | '(darcsum-marked-face darcsum-need-action-marked-face))))))) 1312 | 1313 | (defun darcsum-next-entity (&optional arg backward) 1314 | "Move to the next file or change. 1315 | With ARG, move that many times. 1316 | BACKWARD non-nil means to go backwards." 1317 | (interactive "p") 1318 | (let (changeset) 1319 | (dotimes (i (or arg 1)) 1320 | (setq changeset (darcsum-changeset-at-point t)) 1321 | (beginning-of-line) 1322 | (while (progn 1323 | (forward-line (if backward -1)) 1324 | (not (or (null (darcsum-get-line-type)) 1325 | (and (looking-at "[0-9i\t]") ; stop at headers 1326 | (not (eq changeset (darcsum-changeset-at-point t)))))))))) 1327 | (unless (darcsum-get-line-type) 1328 | (goto-char (if backward (point-max) (point-min))) ;; Wrap around 1329 | (forward-line (if backward -3 3))) 1330 | (darcsum-reposition)) 1331 | 1332 | (defun darcsum-next-line (&optional arg) 1333 | "Move to the next file or change. 1334 | With ARG, move that many times." 1335 | (interactive "p") 1336 | (darcsum-next-entity arg)) 1337 | 1338 | (defun darcsum-previous-line (&optional arg) 1339 | "Move to the previous file or change. 1340 | With ARG, move that many times." 1341 | (interactive "p") 1342 | (darcsum-next-entity arg t)) 1343 | 1344 | (defun darcsum-mark-and-next-entity (&optional arg) 1345 | "Mark then move to the next unmarked directory, file or change. 1346 | With ARG, mark and move that many times." 1347 | (interactive "P") 1348 | (unless 1349 | (darcsum-apply-and-next-entity 1350 | (function darcsum-change-add-mark) 1351 | (function darcsum-changeset-any-unmarked-p) 1352 | arg) 1353 | (message "No more unmarked changes.")) 1354 | (darcsum-refresh)) 1355 | 1356 | (defun darcsum-unmark-and-next-entity (&optional arg) 1357 | "Unmark then move to the next marked directory, file or change. 1358 | With ARG, mark and move that many times." 1359 | (interactive "P") 1360 | (unless 1361 | (darcsum-apply-and-next-entity 1362 | (function darcsum-change-remove-mark) 1363 | (function darcsum-changeset-any-marked-p) 1364 | arg) 1365 | (message "No more marked changes.")) 1366 | (darcsum-refresh)) 1367 | 1368 | (defun darcsum-apply-and-next-entity (func next-p &optional arg backward) 1369 | "Apply FUNC to current changeset and move forward until NEXT-P changeset. 1370 | With ARG, mark and move that many times. With BACKWARD, move to previous. 1371 | Return nil if there is no changeset matching NEXT-P." 1372 | (let ((started (point)) 1373 | changeset 1374 | (type (darcsum-get-line-type))) 1375 | (if (catch 'exit 1376 | (ignore 1377 | (dotimes (i (or arg 1)) 1378 | (setq changeset (darcsum-changeset-at-point t)) 1379 | (darcsum-apply-to-changes changeset func) 1380 | (beginning-of-line) 1381 | (while (progn 1382 | (forward-line (if backward -1)) 1383 | (unless (darcsum-get-line-type) 1384 | (throw 'exit t)) 1385 | (not (and 1386 | (looking-at "[0-9i\t]") ; stop at headers 1387 | ; Don't stop at dir unless started from dir 1388 | (or (eq type 'dir) 1389 | (not (eq 'dir (darcsum-get-line-type)))) 1390 | (funcall next-p (darcsum-changeset-at-point t)))))) 1391 | ))) 1392 | (ignore (goto-char started)) 1393 | t))) 1394 | 1395 | (defcustom darcsum-diff-switches nil 1396 | "*diff(1) switches used by `darcsum-diff'." 1397 | :type 'string 1398 | :group 'darcsum) 1399 | 1400 | (defun darcsum-diff () 1401 | "Show the changes made to current selection." 1402 | ; XXX - does not work with darcs2! 1403 | (interactive) 1404 | (let ((type (darcsum-get-line-type)) 1405 | (original-path (darcsum-original-path (point)))) 1406 | (cond 1407 | ((not original-path) 1408 | (error "No record of this file in darcs")) 1409 | ((eq type 'dir)) 1410 | ((or (eq type 'file) 1411 | (eq type 'change)) 1412 | (require 'diff) ; for `diff-switches' 1413 | (diff original-path 1414 | (darcsum-path (point)) 1415 | (or darcsum-diff-switches diff-switches)))))) 1416 | 1417 | (defun darcsum-path (pos) 1418 | (expand-file-name (get-text-property pos 'darcsum-line-path))) 1419 | 1420 | (defun darcsum-original-path (pos) 1421 | (let* ((path (get-text-property pos 'darcsum-line-path)) 1422 | (pristine-path (expand-file-name path "_darcs/pristine")) 1423 | (current-path (expand-file-name path "_darcs/current"))) 1424 | (cond ((file-readable-p pristine-path) pristine-path) 1425 | ((file-readable-p current-path) current-path)))) 1426 | 1427 | (defun darcsum-delete () 1428 | "Remove selected changeset from the view." 1429 | (interactive) 1430 | (setq darcsum-data 1431 | (darcsum-remove-changeset darcsum-data 1432 | (darcsum-selected-changeset))) 1433 | (darcsum-refresh)) 1434 | 1435 | (defun darcsum-remove () 1436 | "Remove a file from the repository. 1437 | 1438 | This runs darcs remove (which undoes accidental addfile or adddir). 1439 | 1440 | If you want to remove an existing file or directory, remove file or 1441 | directory otherwise and record change." 1442 | (interactive) 1443 | (darcsum-check-darcsum-mode) 1444 | (let ((changeset (darcsum-changeset-at-point t)) 1445 | (type (darcsum-get-line-type)) 1446 | (path (get-text-property (point) 'darcsum-line-path))) 1447 | (cond 1448 | ((eq (caadar changeset) 'adddir) 1449 | (setq changeset (cdr changeset)) 1450 | (while (memq (caadar changeset) '(newfile newdir)) 1451 | (setq changeset (cdr changeset))) 1452 | (if changeset 1453 | (error "Remove pending changes in directory first"))) 1454 | ((eq (caadar changeset) 'addfile) 1455 | (setq changeset (cdr changeset)) 1456 | (while (numberp (caadar changeset)) 1457 | (setq changeset (cdr changeset))) 1458 | (if changeset 1459 | (error "First undo pending changes in file"))) 1460 | (t 1461 | (error "Not added file or directory"))) 1462 | (unless (= 0 (call-process darcsum-program nil t nil 1463 | "remove" path)) 1464 | (error "Error running `darcs remove'")) 1465 | (darcsum-redo))) 1466 | 1467 | (defun darcsum-add () 1468 | "Put new file or directory under Darcs control." 1469 | (interactive) 1470 | (darcsum-check-darcsum-mode) 1471 | (let ((changeset (darcsum-selected-changeset)) 1472 | file path change added) 1473 | (dolist (file changeset) 1474 | (setq path (car file) 1475 | change (cadr file)) 1476 | (if (memq (car change) '(newfile newdir)) 1477 | (with-temp-buffer 1478 | (if (/= 0 (call-process 1479 | darcsum-program nil t nil "add" path)) 1480 | (error "Error running `darcs add' for `%s'" path) 1481 | (setcar change (cdr (assoc (car change) '((newfile . addfile) 1482 | (newdir . adddir)))))) 1483 | (setq added t)))) 1484 | (unless added 1485 | (error "No new entries, cannot add"))) 1486 | (darcsum-refresh)) 1487 | 1488 | (defun darcsum-add-to-boring (path) 1489 | "Add current file or directory to the boring file. 1490 | 1491 | Propose the insertion of a regexp suitable to permanently ignore 1492 | the file or the directory at point into the boring file." 1493 | (interactive 1494 | (let ((type (darcsum-get-line-type)) 1495 | (path (get-text-property (point) 'darcsum-line-path))) 1496 | (if (string-match "^\\./" path) 1497 | (setq path (substring path 2))) 1498 | (setq path (regexp-quote path)) 1499 | (cond 1500 | ((eq type 'dir) 1501 | (setq path (concat "(^|/)" path "($|/)"))) 1502 | ((memq type '(file change)) 1503 | (setq path (concat "(^|/)" path "$")))) 1504 | (list (read-string "Add to boring list: " path)))) 1505 | (save-excursion 1506 | (set-buffer (find-file-noselect "_darcs/prefs/boring")) 1507 | (goto-char (point-max)) 1508 | (insert path ?\n) 1509 | (save-buffer) 1510 | (kill-buffer (current-buffer))) 1511 | (darcsum-redo)) 1512 | 1513 | (defun darcsum-add-change-log-entry () 1514 | "Execute `add-change-log-entry' on the current file." 1515 | (interactive) 1516 | (let ((type (darcsum-get-line-type))) 1517 | (cond 1518 | ((eq type 'dir)) 1519 | ((or (eq type 'file) 1520 | (eq type 'change)) 1521 | (darcsum-goto) 1522 | (add-change-log-entry))))) 1523 | 1524 | (defun darcsum-ediff () 1525 | "Like `darcsum-diff' but in an Ediff session." 1526 | (interactive) 1527 | (let ((type (darcsum-get-line-type))) 1528 | (cond 1529 | ((eq type 'dir)) 1530 | ((or (eq type 'file) 1531 | (eq type 'change)) 1532 | (let ( (pristine-filename (darcsum-original-path (point))) 1533 | (working-filename (darcsum-path (point))) 1534 | ;; Save the current window configuration, before opening ediff 1535 | (old-window-configuration (current-window-configuration)) 1536 | ) 1537 | (progn 1538 | (save-excursion 1539 | ;; Pristine copy should not be modified 1540 | (find-file-read-only pristine-filename) 1541 | ;; It should be clear this is not a buffer you want to touch. 1542 | (rename-buffer (concat "*darcsum-pristine:" pristine-filename "*")) 1543 | ) 1544 | (ediff pristine-filename working-filename 1545 | ;;Add this anonymous function as a startup hook in ediff-mode 1546 | (lambda () 1547 | (progn 1548 | (setq darcsum-pre-ediff-window-configuration 1549 | old-window-configuration) 1550 | ;; After we quit THIS PARTICULAR ediff buffer, 1551 | ;; restore the old window configuration 1552 | (add-hook 1553 | 'ediff-quit-hook 1554 | (lambda () (set-window-configuration 1555 | darcsum-pre-ediff-window-configuration) 1556 | ) nil t) 1557 | ))) 1558 | )))))) 1559 | 1560 | (defun darcsum-ediff-merge () 1561 | "Start an `ediff-merge' session on the current selection." 1562 | (interactive) 1563 | (let ((type (darcsum-get-line-type))) 1564 | (cond 1565 | ((eq type 'dir)) 1566 | ((or (eq type 'file) 1567 | (eq type 'change)) 1568 | (ediff-merge (darcsum-original-path (point)) 1569 | (darcsum-path (point))))))) 1570 | 1571 | (defun darcsum-redo (&optional arg) 1572 | "Refresh the status, redoing `darcs whatsnew'." 1573 | (interactive "P") 1574 | (darcsum-check-darcsum-mode) 1575 | (let ((dir (expand-file-name darcsum-subdirectory default-directory)) 1576 | (look-for-adds (or arg darcsum-look-for-adds)) 1577 | (darcsum-default-expanded t)) 1578 | (message "Re-running darcsum-whatsnew") 1579 | (let ((changes (darcsum-whatsnew 1580 | dir look-for-adds t darcsum-show-context))) 1581 | (setq darcsum-data 1582 | (darcsum-merge-changeset darcsum-data changes))) 1583 | (darcsum-refresh))) 1584 | 1585 | (defun darcsum-quit () 1586 | "Close the darcsum buffer and quit." 1587 | (interactive) 1588 | (darcsum-check-darcsum-mode) 1589 | (kill-buffer (current-buffer))) 1590 | 1591 | 1592 | (defun darcsum-add-comment () 1593 | "Similar to `add-change-log-entry'. 1594 | 1595 | Inserts the entry in the darcs comment file instead of the ChangeLog." 1596 | ;; This is mostly copied from add-log.el and Xtla. Perhaps it would 1597 | ;; be better to split add-change-log-entry into several functions 1598 | ;; and then use them, but that wouldn't work with older versions of 1599 | ;; Emacs. 1600 | (interactive) 1601 | (require 'add-log) 1602 | (let* ((defun (add-log-current-defun)) 1603 | (buf-file-name (if (and (boundp 'add-log-buffer-file-name-function) 1604 | add-log-buffer-file-name-function) 1605 | (funcall add-log-buffer-file-name-function) 1606 | buffer-file-name)) 1607 | (buffer-file (if buf-file-name (expand-file-name buf-file-name))) 1608 | ; (file-name (tla-make-log)) 1609 | ;; Set ENTRY to the file name to use in the new entry. 1610 | (entry (add-log-file-name buffer-file default-directory)) 1611 | beg 1612 | bound 1613 | narrowing) 1614 | (switch-to-buffer-other-window (get-buffer-create "*darcs comment*")) 1615 | 1616 | (goto-char (point-min)) 1617 | (forward-line 1) ; skip header 1618 | ;; Now insert the new line for this entry. 1619 | (cond ((re-search-forward "^\\s *\\*\\s *$" bound t) 1620 | ;; Put this file name into the existing empty entry. 1621 | (if entry 1622 | (insert entry))) 1623 | ((let (case-fold-search) 1624 | (re-search-forward 1625 | (concat (regexp-quote (concat "* " entry)) 1626 | ;; Don't accept `foo.bar' when 1627 | ;; looking for `foo': 1628 | "\\(\\s \\|[(),:]\\)") 1629 | bound t)) 1630 | ;; Add to the existing entry for the same file. 1631 | (re-search-forward "^\\s *$\\|^\\s \\*\\|\\'") 1632 | (goto-char (match-beginning 0)) 1633 | ;; Delete excess empty lines; make just 2. 1634 | (while (and (not (eobp)) (looking-at "^\\s *$")) 1635 | (delete-region (point) (line-beginning-position 2))) 1636 | (insert-char ?\n 2) 1637 | (forward-line -2) 1638 | (indent-relative-maybe)) 1639 | (t 1640 | ;; Make a new entry. 1641 | (goto-char (point-max)) 1642 | (re-search-backward "^." nil t) 1643 | (end-of-line) 1644 | (insert "\n* ") 1645 | (if entry (insert entry)))) 1646 | ;; Now insert the function name, if we have one. 1647 | ;; Point is at the entry for this file, 1648 | ;; either at the end of the line or at the first blank line. 1649 | (if defun 1650 | (progn 1651 | ;; Make it easy to get rid of the function name. 1652 | (undo-boundary) 1653 | (unless (save-excursion 1654 | (beginning-of-line 1) 1655 | (looking-at "\\s *$")) 1656 | (insert ?\ )) 1657 | ;; See if the prev function name has a message yet or not 1658 | ;; If not, merge the two entries. 1659 | (let ((pos (point-marker))) 1660 | (if (and (skip-syntax-backward " ") 1661 | (skip-chars-backward "):") 1662 | (looking-at "):") 1663 | (progn (delete-region (+ 1 (point)) (+ 2 (point))) t) 1664 | (> fill-column (+ (current-column) (length defun) 3))) 1665 | (progn (delete-region (point) pos) 1666 | (insert ", ")) 1667 | (goto-char pos) 1668 | (insert "(")) 1669 | (set-marker pos nil)) 1670 | (insert defun "): ")) 1671 | ;; No function name, so put in a colon unless we have just a star. 1672 | (unless (save-excursion 1673 | (beginning-of-line 1) 1674 | (looking-at "\\s *\\(\\*\\s *\\)?$")) 1675 | (insert ": "))))) 1676 | 1677 | (defvar darcsum-mode-abbrev-table nil 1678 | "Abbrev table used while in darcsum-mode mode.") 1679 | (define-abbrev-table 'darcsum-mode-abbrev-table ()) 1680 | 1681 | (global-set-key "\C-xD" 'darcsum-add-comment) 1682 | 1683 | (defvar darcsum-mode-map 1684 | (let ((map (make-sparse-keymap))) 1685 | (suppress-keymap map) 1686 | (define-key map [return] 'darcsum-toggle) ; ?? 1687 | (define-key map "\C-m" 'darcsum-toggle) 1688 | (define-key map "\C-\M-m" 'darcsum-show) 1689 | (define-key map "\C-c\C-c" 'darcsum-goto) 1690 | (define-key map [tab] 'darcsum-next-entity) 1691 | (define-key map [space] 'darcsum-mark-and-next-entity) 1692 | (define-key map " " 'darcsum-mark-and-next-entity) 1693 | (define-key map [backspace] 'darcsum-unmark-and-next-entity) 1694 | (define-key map [delete] 'darcsum-unmark-and-next-entity) 1695 | (define-key map "?" 'describe-mode) 1696 | (define-key map "f" 'darcsum-find-file) 1697 | (define-key map "v" 'darcsum-display-change) 1698 | (define-key map "=" 'darcsum-diff) 1699 | (define-key map "e" 'darcsum-ediff) 1700 | (define-key map "E" 'darcsum-ediff-merge) 1701 | (define-key map "g" 'darcsum-redo) 1702 | (define-key map "n" 'darcsum-next-line) 1703 | (define-key map "p" 'darcsum-previous-line) 1704 | (define-key map "a" 'darcsum-add) 1705 | (define-key map "l" 'darcsum-add-change-log-entry) 1706 | (define-key map "c" 'darcsum-record) 1707 | (define-key map "R" 'darcsum-record) 1708 | (define-key map "U" 'darcsum-revert) 1709 | (define-key map "u" 'darcsum-toggle-context) 1710 | (define-key map "d" 'darcsum-delete) 1711 | (define-key map "r" 'darcsum-remove) 1712 | (define-key map "M" 'darcsum-move) 1713 | (define-key map "m" 'darcsum-toggle-mark) 1714 | (define-key map [button2] 'darcsum-mouse-toggle-mark) 1715 | (define-key map "i" 'darcsum-add-to-boring) 1716 | (define-key map "B" 'darcsum-add-to-boring) 1717 | (define-key map "q" 'darcsum-quit) 1718 | map)) 1719 | 1720 | (easy-menu-define darcsum-menu darcsum-mode-map "Menu used in `darcsum-mode'." 1721 | '("Darcs summary" 1722 | ["Open file.." darcsum-find-file 1723 | (or (darcsum-line-is 'file) 1724 | (darcsum-line-is 'change))] 1725 | [" ..other window" darcsum-find-file-other-window 1726 | (or (darcsum-line-is 'file) 1727 | (darcsum-line-is 'change))] 1728 | ["Display in other window" darcsum-display-file t] 1729 | ("Differences" 1730 | ["Interactive diff" darcsum-ediff t] 1731 | ["Current diff" darcsum-diff t] 1732 | ["Interactive merge" darcsum-ediff-merge t]) 1733 | ;; ["View log" darcsum-log t] 1734 | "--" 1735 | ["Re-examine" darcsum-redo t] 1736 | ["Record changes" darcsum-record t] ; fixme: condition 1737 | ["Amend last changeset" darcsum-amend t] ; fixme: condition 1738 | ;; ["Tag" darcsum-tag t] 1739 | ["Undo changes" darcsum-revert t] ; fixme: condition 1740 | ["Add" darcsum-add (darcsum-line-is 'new)] 1741 | ["Remove" darcsum-remove (darcsum-line-is 'file)] 1742 | ["Ignore" darcsum-add-to-boring (darcsum-line-is 'file)] 1743 | ["Add ChangeLog" darcsum-add-change-log-entry t] 1744 | ["Delete" darcsum-delete t] 1745 | "--" 1746 | ["(Un)activate change" darcsum-toggle t] 1747 | ["(Un)mark change" darcsum-toggle-mark 1748 | :style toggle 1749 | :selected (darcsum-line-is 'marked)] 1750 | ["Next file/change" darcsum-next-line t] 1751 | ["Previous file/change" darcsum-previous-line t] 1752 | ["Move changeset" darcsum-move t] 1753 | ["Show change context" darcsum-toggle-context 1754 | :style toggle :selected darcsum-show-context] 1755 | "--" 1756 | ["Quit" darcsum-quit t] 1757 | )) 1758 | 1759 | (define-derived-mode darcsum-mode fundamental-mode "Darcs" 1760 | "Darcs summary mode is for previewing changes to become part of a patch. 1761 | \\{darcsum-mode-map}" 1762 | :group 'darcsum 1763 | (make-local-variable 'darcsum-data) 1764 | (make-local-variable 'darcsum-look-for-adds) 1765 | (make-local-variable 'darcsum-show-context) 1766 | (make-local-variable 'darcsum-subdirectory) 1767 | (setq darcsum-data nil) 1768 | (if (featurep 'xemacs) 1769 | (easy-menu-add darcsum-menu darcsum-mode-map))) 1770 | 1771 | (put 'darcsum-mode 'mode-class 'special) 1772 | 1773 | (defun darcsum-display (changeset &optional look-for-adds sub-directory) 1774 | "Display CHANGESET from SUB-DIRECTORY in a buffer. 1775 | 1776 | If there there already is a buffer for displaying changes in this darcs 1777 | repository (and subdirectory within it), use the existing buffer (unless 1778 | darcsum-display-with-existing-buffer is nil)." 1779 | (unless sub-directory (setq sub-directory ".")) 1780 | (with-current-buffer 1781 | (or (if darcsum-display-with-existing-buffer 1782 | (darcsum-find-buffer default-directory sub-directory)) 1783 | (darcsum-new-buffer default-directory sub-directory)) 1784 | (setq darcsum-data (darcsum-merge-changeset darcsum-data changeset)) 1785 | (setq darcsum-look-for-adds look-for-adds) 1786 | (setq darcsum-subdirectory sub-directory) 1787 | (darcsum-refresh 0) 1788 | (darcsum-next-line 0) 1789 | (unless (darcsum-changeset-all-visible-p darcsum-data) 1790 | (message 1791 | "Press %s to show all changes" 1792 | (darcsum-where-is (function darcsum-show)))) 1793 | (switch-to-buffer (current-buffer)))) 1794 | 1795 | (defcustom darcsum-display-with-existing-buffer t 1796 | "*If nil, always create new buffer to display changeset." 1797 | :type 'boolean 1798 | :group 'darcsum) 1799 | 1800 | (defun darcsum-new-buffer (&optional dir subdir) 1801 | "Generate new darcsum buffer for (SUBDIR in DIR)." 1802 | (setq dir (file-name-nondirectory 1803 | (directory-file-name (file-name-directory 1804 | (or dir default-directory))))) 1805 | (if (string= subdir ".") 1806 | (setq subdir nil)) 1807 | (with-current-buffer 1808 | (generate-new-buffer 1809 | (concat "*darcs " dir 1810 | (when subdir "/") 1811 | (when subdir 1812 | (if (file-name-absolute-p subdir) 1813 | (file-relative-name subdir) 1814 | subdir)) 1815 | "*")) 1816 | (darcsum-mode) 1817 | (current-buffer))) 1818 | 1819 | (defun darcsum-find-buffer (&optional dir subdir) 1820 | "Get existing darcsum buffer (for SUBDIR in DIR)." 1821 | (catch 'exit 1822 | (ignore 1823 | (let (buffer locals mode buffer-dir) 1824 | (dolist (buffer (buffer-list)) 1825 | (setq locals (buffer-local-variables buffer) 1826 | mode (cdr (assq 'major-mode locals)) 1827 | buffer-dir (cdr (assq 'default-directory locals)) 1828 | buffer-subdir (cdr (assq 'darcsum-subdirectory locals))) 1829 | (if (and (eq mode 'darcsum-mode) 1830 | (or (null dir) (string= buffer-dir dir)) 1831 | (or (null subdir) (string= buffer-subdir subdir))) 1832 | (throw 'exit buffer))))))) 1833 | 1834 | (defun darcsum-where-is (command) 1835 | "Return the representation of key sequences that invoke specified COMMAND." 1836 | (let ((keys (where-is-internal command))) 1837 | (if keys 1838 | (if (featurep 'xemacs) 1839 | (sorted-key-descriptions keys) 1840 | (mapconcat 'key-description keys ", ")) 1841 | (format "M-x %s RET" command)))) 1842 | 1843 | (defun darcsum-repository-root (&optional start-directory) 1844 | "Return the root of the repository, or nil if there isn't one." 1845 | (let ((dir (or start-directory 1846 | default-directory 1847 | (error "No start directory given")))) 1848 | (if (car (directory-files dir t "^_darcs$")) 1849 | dir 1850 | (let ((next-dir (file-name-directory (directory-file-name 1851 | (file-truename dir))))) 1852 | (unless (or (equal dir next-dir) (null next-dir)) 1853 | (darcsum-repository-root next-dir)))))) 1854 | 1855 | (defcustom darcsum-whatsnew-switches nil 1856 | "*Switches for `darcsum-whatsnew'." 1857 | :type 'string 1858 | :group 'darcsum) 1859 | 1860 | (defcustom darcsum-whatsnew-at-toplevel t 1861 | "*Use top-level repository directory as default argument to \ 1862 | `darcsum-whatsnew'." 1863 | :type 'boolean 1864 | :group 'darcsum) 1865 | 1866 | ;;; This is the entry code, M-x darcsum-whatsnew 1867 | 1868 | ;;;###autoload 1869 | (defun darcsum-whatsnew (directory 1870 | &optional look-for-adds no-display show-context) 1871 | "Run `darcs whatsnew' in DIRECTORY, displaying the output in `darcsum-mode'. 1872 | 1873 | When invoked interactively, prompt for the directory to display changes for." 1874 | (interactive 1875 | ; fancy "DDirectory: \nP" 1876 | (let ((root 1877 | (if darcsum-whatsnew-at-toplevel 1878 | (darcsum-repository-root) 1879 | default-directory))) 1880 | (list (funcall (if (fboundp 'read-directory-name) 1881 | 'read-directory-name 1882 | 'read-file-name) 1883 | "Directory: " root root) 1884 | (or darcsum-look-for-adds current-prefix-arg)))) 1885 | (with-temp-buffer 1886 | (cd directory) 1887 | (let ((repo (darcsum-repository-root))) 1888 | (unless repo 1889 | (error "Directory `%s' is not under darcs version control" 1890 | directory)) 1891 | (cd repo)) 1892 | (let* ((process-environment (append 1893 | darcsum-environment 1894 | darcsum-output-environment 1895 | process-environment)) 1896 | (args (append 1897 | ;; Build a list of arguments for call-process 1898 | (list darcsum-program nil t nil) 1899 | (list "whatsnew" "--no-summary") 1900 | (darcsum-fix-switches darcsum-whatsnew-switches) 1901 | ; Arguments override user preferences 1902 | (unless (null look-for-adds) (list "--look-for-adds")) 1903 | (unless (null show-context) (list "--unified")) 1904 | (unless (string= directory default-directory) 1905 | (list (file-relative-name 1906 | directory default-directory))) 1907 | nil)) 1908 | (result (apply 'call-process args)) 1909 | message) 1910 | (if (/= result 0) 1911 | (if (= result 1) 1912 | (ignore (and (interactive-p) (message "No changes!"))) 1913 | (ignore 1914 | (if (fboundp 'clone-buffer) 1915 | (progn 1916 | (condition-case nil (kill-buffer "*darcs-output*") (error nil)) 1917 | (clone-buffer "*darcs-output*" t)) 1918 | (goto-char (point-min)) 1919 | (if (looking-at "\n*darcs failed\\(: .*\\)") 1920 | (setq message (match-string 1)))) 1921 | (error (concat "Error running darcs whatsnew" message)))) 1922 | (let ((changes (darcsum-read-changeset darcsum-default-expanded))) 1923 | (if (and changes (not no-display)) 1924 | (darcsum-display changes look-for-adds 1925 | (directory-file-name 1926 | (file-relative-name directory)))) 1927 | changes))))) 1928 | 1929 | ; lifted from diff.el 1930 | (defun darcsum-fix-switches (switch-spec) 1931 | "Parse SWITCH-SPEC into a list of switches. 1932 | Leave it be if it's not a string." 1933 | (if (stringp switch-spec) 1934 | (let (result (start 0)) 1935 | (while (string-match "\\(\\S-+\\)" switch-spec start) 1936 | (setq result (cons (substring switch-spec (match-beginning 1) 1937 | (match-end 1)) 1938 | result) 1939 | start (match-end 0))) 1940 | (nreverse result)) 1941 | switch-spec)) 1942 | 1943 | ;;;###autoload 1944 | (defun darcsum-view (directory) 1945 | "View the contents of the current buffer as a darcs changeset for DIRECTORY. 1946 | More precisely, searches forward from point for the next changeset-like region, 1947 | and attempts to parse that as a darcs patch. 1948 | 1949 | When invoked interactively, prompts for a directory; by default, the current 1950 | working directory is assumed." 1951 | (interactive 1952 | (list (funcall (if (fboundp 'read-directory-name) 1953 | 'read-directory-name 1954 | 'read-file-name) 1955 | "Directory: " 1956 | (darcsum-repository-root)))) 1957 | (unless (file-directory-p (expand-file-name "_darcs" directory)) 1958 | (error "Directory `%s' is not under darcs version control" 1959 | directory)) 1960 | (if (or (and (search-forward "{" nil t) 1961 | (goto-char (1- (point)))) 1962 | (search-backward "{" nil t)) 1963 | (let ((changes (darcsum-parse-changeset)) 1964 | (default-directory directory)) 1965 | (darcsum-display changes)) 1966 | (error "Cannot find a darcs patch in the current buffer"))) 1967 | 1968 | ;;; Gnus integration code, for viewing darcs patches in a changeset 1969 | ;;; buffer. They cannot be recorded from there, however, since the 1970 | ;;; changes have not been applied to the working tree. To do this, 1971 | ;;; you must still pipe the message to "darcs apply". This code only 1972 | ;;; works as a browser for now. 1973 | 1974 | (defvar darcsum-install-gnus-code nil) 1975 | 1976 | (when darcsum-install-gnus-code 1977 | (eval-when-compile (require 'gnus) 1978 | (require 'gnus-sum) 1979 | (require 'gnus-art) 1980 | (require 'gnus-fun) 1981 | (require 'gnus-win) 1982 | (require 'gnus-util) 1983 | (require 'mm-view) 1984 | (require 'mail-parse) 1985 | 1986 | (defun mm-view-darcs-patch (handle) 1987 | "View HANDLE as a darcs patch, using darcsum.el." 1988 | (let* ((name (mail-content-type-get (mm-handle-type handle) 'name)) 1989 | (directory 1990 | (funcall (if (fboundp 'read-directory-name) 1991 | 'read-directory-name 1992 | 'read-file-name) 1993 | "Apply patch to directory: "))) 1994 | (mm-with-unibyte-buffer 1995 | (mm-insert-part handle) 1996 | (let ((coding-system-for-write 'binary)) 1997 | (goto-char (point-min)) 1998 | (darcsum-view directory) 1999 | (delete-other-windows))))) 2000 | 2001 | (defun gnus-mime-view-darcs-patch () 2002 | "Pipe the MIME part under point to a process." 2003 | (interactive) 2004 | (gnus-article-check-buffer) 2005 | (let ((data (get-text-property (point) 'gnus-data))) 2006 | (when data 2007 | (mm-view-darcs-patch data)))) 2008 | 2009 | (defun gnus-article-view-darcs-patch (n) 2010 | "Pipe MIME part N, which is the numerical prefix." 2011 | (interactive "p") 2012 | (gnus-article-part-wrapper n 'mm-view-darcs-patch)) 2013 | 2014 | (eval-after-load "gnus-art" 2015 | '(progn 2016 | (nconc gnus-mime-action-alist 2017 | '(("apply darcs patch" . gnus-mime-view-darcs-patch))) 2018 | (nconc gnus-mime-button-commands 2019 | '((gnus-mime-view-darcs-patch "V" "Apply darcs patch..."))))) 2020 | 2021 | (defun gnus-summary-view-darcs-patch (directory) 2022 | "Apply the current article as a darcs patch to DIRECTORY." 2023 | (interactive "DApply patch to directory: ") 2024 | (gnus-summary-select-article) 2025 | (let ((mail-header-separator "")) 2026 | (gnus-eval-in-buffer-window gnus-article-buffer 2027 | (save-restriction 2028 | (widen) 2029 | (goto-char (point-min)) 2030 | (darcsum-view directory))))) 2031 | 2032 | (eval-after-load "gnus-sum" 2033 | '(progn 2034 | (define-key gnus-summary-mime-map "V" 'gnus-article-view-darcs-patch) 2035 | (define-key gnus-summary-article-map "V" 2036 | 'gnus-summary-view-darcs-patch))))) 2037 | 2038 | (provide 'darcsum) 2039 | ;;; darcsum.el ends here 2040 | --------------------------------------------------------------------------------