├── .gitignore
├── README.md
├── REFERENCE.md
├── racket-rewrites.el
└── sexp-rewrite.el


/.gitignore:
--------------------------------------------------------------------------------
1 | *.elc
2 | sexp-rewrite-pkg.el
3 | sexp-rewrite-autoloads.el
4 | 


--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
  1 | # sexp-rewrite
  2 | 
  3 | sexp-rewrite (abbreviated sexprw) is an Emacs package for doing
  4 | pattern-based rewriting of sexp-structured code---ie, code in Lisp,
  5 | Scheme, and primarily Racket.
  6 | 
  7 | Some examples of pattern-based rewriting are:
  8 | 
  9 |  - Turn a chain of `if` expressions into a `cond` expression.
 10 | 
 11 |  - Rewrite an application of `map` with `lambda` to `for/list`---or
 12 |    `andmap` to `for/and`, etc.
 13 | 
 14 |  - Turn a `letrec` into a sequence of internal definitions.
 15 | 
 16 | The pattern language is simple enough that you can easily define your
 17 | own rewriting rules.
 18 | 
 19 | Transformations preserve comments and are halfway decent at preserving
 20 | formatting, with the occasional help of appropriate spacing
 21 | annotations.
 22 | 
 23 | ## Try it out
 24 | 
 25 | Visit `sexp-rewrite.el` and evaluate the buffer (`M-x eval-buffer`).
 26 | Then visit `racket-rewrites.el` and evaluate that buffer too.
 27 | 
 28 | Most of the rewrite rules (or "tactics") in `racket-rewrites.el` have
 29 | examples after them.  Go to the example labeled "`example for
 30 | if-to-cond...`" and place the cursor at the first left
 31 | parenthesis---that is, at `(if (< x 10)...`.
 32 | 
 33 | Run the `if-to-cond` tactic by entering `M-x sexprw-execute-tactic`
 34 | and then `if-to-cond`.
 35 | The `if` expression gets rewritten to a `cond` expression---but only
 36 | the first `if`; there are still `if` expressions left in the `else` branch.
 37 | Now run the `cond-else-absorb-if` tactic. There's a keybinding for
 38 | `sexprw-execute-tactic` that makes executing a specific tactic
 39 | quicker: `C-c C-s x`. Then type `cond-else-absorb-if` at the prompt
 40 | (you can use tab completion to save typing).
 41 | The `if` expression gets "absorbed" into the `cond`. There's just one
 42 | `if` left, but it's inside a `let`, so let's leave it alone for now.
 43 | 
 44 | What a bother to have to type in the tactic names. Fortunately,
 45 | there's an even quicker way.
 46 | 
 47 | Undo twice (`C-/ C-/`) to reset the example to the original form,
 48 | and make sure the cursor is back at the beginning of the example.
 49 | Now enter `C-c C-s e` (which runs the `sexprw-auto-expression`
 50 | command). The command automatically tries a bunch of tactics until one
 51 | works, and it reports the name of the tactic in the minibuffer.
 52 | 
 53 | Faster?
 54 | 
 55 | Undo once (`C-/`) to reset the example again.  Now type `C-c C-s r e`,
 56 | which repeatedly tries tactics (up to about a hundred times) until
 57 | they stop working. This time we get the first two `if` expressions in
 58 | one shot, as well as the `if` under the `let`, which can be converted
 59 | to an `=>` clause.
 60 | 
 61 | Note that the rewrite that produced the `=>` can be unsafe: the
 62 | else-branch expression was originally in the scope of the `let`-bound
 63 | variable, but after rewriting it is in a separate clause. That's
 64 | *usually* not a problem, because the variable is always known to be
 65 | false in the else, branch (unless it's mutated...) so there's no
 66 | reason to refer to it. But it's always a good idea to keep an eye on
 67 | the tactics applied to make sure they don't break your code.
 68 | 
 69 | ## Keybindings
 70 | 
 71 | The prefix for all sexp-rewrite commands is `C-c C-s`.
 72 | 
 73 | The following keybindings invoke sexp-rewrite tactics:
 74 | 
 75 | - `<prefix> x` : runs `sexprw-execute-tactic`, which applies the given tactic
 76 | 
 77 | - `<prefix> e` : runs `sexprw-auto-expression`
 78 | - `<prefix> r e` : runs `sexprw-auto-expression` repeatedly until no tactic applies
 79 | - `<prefix> d` : runs `sexprw-auto-definition`
 80 | - `<prefix> r d` : runs `sexprw-auto-definition` repeatedly until no tactic applies
 81 | 
 82 | The following keybindings manipulate sexpagons:
 83 | 
 84 | - `<prefix> k` : runs `sexprw-kill-next-sexpagon-sexp`
 85 | - `<prefix> w` : runs `sexprw-kill-sexpagon-region`
 86 | - `<prefix> y` : runs `sexprw-yank-sexpagon`
 87 | - `<prefix> M-SPC` : runs `sexprw-collapse-space/move-sexps`
 88 | 
 89 | The following other keybindings are also provided:
 90 | 
 91 | - `<prefix> s` : runs `sexprw-search-pattern`, which searches forward
 92 |   for a term matching the given sexprw pattern
 93 | 
 94 | - `<prefix> [` : runs `sexprw-squarify`, which converts parentheses to square brackets
 95 |   for all following terms at the given level
 96 | 
 97 | - `<prefix> (` : runs `sexprw-roundify`, which converts square brackets to parentheses
 98 |   for all following terms at the given level
 99 | 
100 | ## Defining Tactics
101 | 
102 | See `REFERENCE.md` for a description of the tactic language.
103 | 
104 | ## Known bugs and limitations
105 | 
106 | This library has a vague notion of sexp syntax. Notions like
107 | improper lists are not supported, and `.` is treated as an
108 | atom. Reader abbreviations like `'` for `quote` are not recognized.
109 | 


--------------------------------------------------------------------------------
/REFERENCE.md:
--------------------------------------------------------------------------------
  1 | # sexp-rewrite Reference
  2 | 
  3 | ## Defining Tactics and Nonterminals
  4 | 
  5 | A tactic consists of a pattern and a template:
  6 | 
  7 |     (define-sexprw-tactic NAME PATTERN TEMPLATE)
  8 | 
  9 | A nonterminal consists of one or more patterns:
 10 | 
 11 |     (define-sexprw-nt NAME
 12 |       MAYBE-ATTRS
 13 |       (pattern PATTERN WITH-CLAUSE ...) ...)
 14 | 
 15 |     where MAYBE-ATTRS = ε | :attributes (ATTR-NAME ...)
 16 |           WITH-CLAUSE = :with PATTERN TEMPLATE
 17 | 
 18 | Pattern variables defined inside of a nonterminals patterns are available as attributes of instances of the nonterminal using the syntax `$pvar.$attr` (see below).
 19 | 
 20 | A tactic name can also be used as a nonterminal name. In addition to the tactic's pattern variables, it also exports an attribute named `$out` with the result of the template.
 21 | 
 22 | 
 23 | ## Patterns
 24 | 
 25 | A pattern is one of the following:
 26 | 
 27 | - `symbol` : matches that literal symbol. The symbol cannot start with a `$` character.
 28 | - `$name` : matches any sexp and binds it to the pattern variable `$name`.
 29 | - `$name:nt` : matches an occurrence of the nonterminal `nt` and binds it to the pattern
 30 |   variable `$name`.
 31 | - `(pattern1 ... patternN)` : ie, a list of patterns (the `...` are not literal)
 32 |   matches a parenthesized sequence of N terms where each term matches the corresponding
 33 |   pattern.
 34 | - `(!@ pattern1 ... patternN)` : matches a non-parenthesized sequence of N terms where
 35 |   each term matches the corresponding pattern.
 36 | - `(!SPLICE pattern1 ... patternN)` : equivalent to `(!@ pattern1 ... patternN)`.
 37 | - `pattern ...` : (ie, a pattern followed by literal ellipses) matches zero or more occurrences
 38 |   of the pattern
 39 | - `(!OR pattern1 ... patternN)` : matches if any of the given patterns match
 40 | - `(!AND pattern1 ... patternN)` : matches if all of the given patterns match
 41 | - `(!GUARD pattern expr)` : to be documented...
 42 | 
 43 | ## Templates
 44 | 
 45 | - `symbol` : produces that literal symbol
 46 | - `$name` : produces the text bound to the pattern variable `$name`
 47 | - `$name.$attr` : produces the text bound to the attribute `$attr` of the pattern variable
 48 |   `$name`, which must be bound to a nonterminal the defines `$attr`.
 49 | - `(template1 ... templateN)` : produces a parenthesized sequence consisting of the results
 50 |   of the N templates.
 51 | - `(!@ template1 ... templateN)` : produces a non-parenthesized sequence consisting of the
 52 |   results of the N templates.
 53 | - `(!SPLICE template1 ... templateN)` : equivalent to `(!@ template1 ... templateN)`
 54 | - `[template1 ... templateN]` : produces a square-bracketed sequence consisting of the
 55 |   results of the N templates.
 56 | - `(!SQ template1 ... templateN)` : equivalent to `[template1 ... templateN]`.
 57 | - `!NL` : prefers a new line before the next non-empty template.
 58 | - `!SP` : prefers a space before the next non-empty template.
 59 | - `!SL` : prefers a new line before the next template, if its contents span multiple lines.
 60 | - `!NOSP` : prevents any space before the next template
 61 | - `template ...` : (ie, a template followed by literal ellipses) produces zero or more
 62 |   instantiations of the template, based on its pattern variables.
 63 | 
 64 | ## Built-in Nonterminals
 65 | 
 66 | The following nonterminals are defined by the sexp-rewrite library:
 67 | 
 68 | - `pure-sexp` : matches a single sexp
 69 | - `sexp` : matches a single sexp, which may have comments preceding it
 70 | - `id` : matches any atom (note: currently includes numbers, etc, too)
 71 | - `rest` : matches the rest of the enclosing sexp, including comments
 72 |   and terms; useful for function bodies, for example
 73 | 
 74 | 
 75 | ## Examples
 76 | 
 77 | This section illustrates the sexprw tactic language with some examples
 78 | from the `racket-rewrites.el` file.
 79 | 
 80 | The `define-absorb-lambda` tactic turns a definition of a variable
 81 | with an explicit `lambda` expression into a function-style definition.
 82 | 
 83 |     (define-sexprw-tactic define-absorb-lambda
 84 |       (define $name:id (lambda ($arg ...) $body:rest))
 85 |       (define ($name $arg ...) !NL $body))
 86 | 
 87 | The following tactic rewrites a `let` binding followed by a test of
 88 | the `let`-bound variable into `cond` with the `=>` notation. Note the
 89 | two occurrences of `$name` in the pattern; the pattern only matches if
 90 | the same identifier is used in both places. Note also that this tactic
 91 | is unsafe if the `let`-bound variable occurs free in the else branch
 92 | of the `if` expression---be careful when using tactics.
 93 | 
 94 |     (define-sexprw-tactic let-if-to-cond
 95 |       ;; Unsafe if $name occurs free in $else
 96 |       (let ([$name:id $rhs])
 97 |         (if $name:id $then $else))
 98 |       (cond [$rhs !SL => (lambda ($name) !SL $then)] !NL
 99 |             [else !SL $else]))
100 | 
101 | The following nonterminal definition gives the form of a `let`
102 | binding, including a special case for function right-hand sides. It
103 | also defines the attribute `$def` as the natural corresponding
104 | definition syntax.
105 | 
106 |     (define-sexprw-nt let-clause
107 |       :attributes ($def)
108 |       (pattern [$name:id (lambda ($arg ...) $body:rest)]
109 |                :with $def (define ($name $arg ...) !SL $body))
110 |       (pattern [$name:id $rhs]
111 |                :with $def (define $name !SL $rhs)))
112 | 
113 | The `letrec-to-definitions` tactic uses the `let-clause` nonterminal
114 | and its `$def` attribute to turn a `letrec` expression's bindings into
115 | internal definitions.
116 | 
117 |     (define-sexprw-tactic letrec-to-definitions
118 |       (letrec ($c:let-clause ...) $body:rest)
119 |       (let () !NL (!@ $c.$def !NL) ... $body))
120 | 


--------------------------------------------------------------------------------
/racket-rewrites.el:
--------------------------------------------------------------------------------
  1 | ;;; racket-rewrites.el --- part of sexp-rewrite package  -*- lexical-binding:t -*-
  2 | 
  3 | ;; Copyright 2013-2019 Ryan Culpepper.
  4 | ;; Released under the terms of the GPL version 3 or later.
  5 | ;; See the top of the sexp-rewrite.el file for details.
  6 | 
  7 | ;;; Commentary:
  8 | 
  9 | ;; ============================================================
 10 | ;; TO DO
 11 | 
 12 | ;; short term
 13 | ;; - build big library of Scheme/Racket tactics
 14 | ;; - build automatic tactics
 15 | ;;;   - general purpose expressions
 16 | ;;;   - coalescing conditionals
 17 | ;;;   - working in definition contexts
 18 | ;;;   - ...?
 19 | ;; - find polite way to set Racket tactics vars only in "Racket mode"
 20 | 
 21 | ;; long term
 22 | ;; - port to DrRacket, etc (see sexp-rewrite todo)
 23 | 
 24 | ;; ============================================================
 25 | ;; On safety
 26 | 
 27 | ;; Need to figure out how to compromise between safety and usability.
 28 | 
 29 | ;; Every last one of these is unsafe if literals don't have their
 30 | ;; standard bindings.
 31 | ;;; 
 32 | ;; Most of them are slightly unsafe.
 33 | 
 34 | ;; ============================================================
 35 | ;; Using racket-rewrites
 36 | 
 37 | ;; Most of the tactics below have strings following the definition
 38 | ;; that let you see the effect of the tactic.
 39 | 
 40 | ;; Once you've tried the tactic, press "C-/" to undo the change and
 41 | ;; restore the example.
 42 | 
 43 | ; ============================================================
 44 | ;; Expression rewrites
 45 | ;; Could be triggered automatically via pattern search.
 46 | 
 47 | ;;; Code:
 48 | 
 49 | (require 'sexp-rewrite)
 50 | 
 51 | (setq sexprw-auto-expression-tactics
 52 |       '(if-to-cond
 53 |         cond-else-absorb-cond
 54 |         cond-else-absorb-if
 55 |         let-if-to-cond
 56 |         cond-else-absorb-let-if
 57 |         letrec-to-definitions
 58 |         let-loop-to-definition
 59 |         ;; let-to-definitions
 60 |         let-absorb-let*
 61 |         let*-absorb-let
 62 |         begin-trivial
 63 |         map for-each ormap andmap foldl
 64 |         build-list for/sum-from-map for/sum-from-for/list
 65 |         in-list-vector->list))
 66 | 
 67 | 
 68 | ;;;###autoload
 69 | (add-hook 'racket-mode-hook #'sexprw-mode)
 70 | 
 71 | ;; --------------------
 72 | ;; If/Cond
 73 | 
 74 | (define-sexprw-tactic if-to-cond
 75 |   (if $test $then $else)
 76 |   (cond [$test !SL $then] !NL
 77 |         [else !SL $else]))
 78 | 
 79 | ' ; example for if-to-cond, cond-else-absorb-*
 80 | (if (< x 10)
 81 |     (f x)
 82 |     (if (> x 10)
 83 |         (g x)
 84 |         (let ((y (h x)))
 85 |           (if y
 86 |               (k y)
 87 |               (+ 0
 88 |                  1)))))
 89 | 
 90 | (define-sexprw-tactic cond-else-absorb-cond
 91 |   (cond $clauses:rest1 [else (cond $more:rest)])
 92 |   (cond $clauses !NL $more))
 93 | 
 94 | (define-sexprw-tactic cond-else-absorb-if
 95 |   (cond $clauses:rest1 [else (if $test $then $else)])
 96 |   (cond $clauses !NL [$test !SL $then] !NL [else !SL $else]))
 97 | 
 98 | (define-sexprw-tactic let-if-to-cond
 99 |   ;; Unsafe if $name occurs free in $else
100 |   (let ([$name:id $rhs])
101 |     (if $name:id $then $else))
102 |   (cond [$rhs !SL => (lambda ($name) !SL $then)] !NL
103 |         [else !SL $else]))
104 | 
105 | (define-sexprw-tactic cond-else-absorb-let-if
106 |   ;; Unsafe if $name occurs free in %else
107 |   (cond $clauses:rest1
108 |         [else (let ([$name:id $rhs]) (if $name:id $then $else))])
109 |   (cond $clauses !NL
110 |         [$rhs !SL => (lambda ($name) !SL $then)] !NL
111 |         [else !SL $else]))
112 | 
113 | ' ; example for let-if-to-cond
114 | (let ([x (assq key alist)])
115 |   (if x
116 |       (cdr x)
117 |       (error 'no-key)))
118 | 
119 | ' ; negative example for let-if-to-cond
120 | (let ((x (assq key alist)))
121 |   (if different-var
122 |       (cdr x)
123 |       (error 'no-key)))
124 | 
125 | ;; --------------------
126 | 
127 | (define-sexprw-nt let-clause
128 |   :attributes ($def)
129 |   (pattern [$name:id (lambda ($arg ...) $body:rest)]
130 |            :with $def (define ($name $arg ...) !SL $body))
131 |   (pattern [$name:id $rhs]
132 |            :with $def (define $name !SL $rhs)))
133 | 
134 | (define-sexprw-tactic letrec-to-definitions
135 |   (letrec ($c:let-clause ...) $body:rest)
136 |   (let () !NL (!@ $c.$def !NL) ... $body))
137 | 
138 | ' ; example for letrec-to-definitions
139 | (letrec ([odd? (lambda (x) (not (even? x)))]
140 |          [even? (lambda (x) (or (zero? x) (even? (sub1 x))))])
141 |   odd?)
142 |   
143 | ' ; another example for letrec-to-definitions
144 | (letrec ([odd? (lambda (x) (not (even? x)))]
145 |          [even? (lambda (x)
146 |                   (or (zero? x)
147 |                       (even? (sub1 x))))])
148 |   odd?)
149 | 
150 | (define-sexprw-tactic let-to-definitions
151 |   ;; Unsafe if any $rhs has free occurrences of any $name, or if $body
152 |   ;; contains definitions of some $x where $x collides with some $name
153 |   ;; or if $x occurs free in any $rhs.
154 |   (let ($c:let-clause ...) $body:rest)
155 |   (let () !NL (!@ $c.$def !NL) ... $body))
156 | 
157 | ' ; example for let-to-definitions
158 | (let ((x 1) (y 2)) (+ x y))
159 | 
160 | (define-sexprw-tactic let-loop-to-definition
161 |   ;; Unsafe if $name occurs free in %init
162 |   (let $loop:id (($arg:id $init) ...) $body:rest)
163 |   (let () !NL
164 |     (define ($loop $arg ...) !SL $body) !NL
165 |     ($loop $init ...)))
166 | 
167 | ;; Would be nice to recognize potential 'for' loops,
168 | ;; but needs a lot more information than we have here.
169 | 
170 | ' ; example for let-loop-to-definition
171 | (let loop ([rejected 0] [racc '()] [lst the-stuff])
172 |   (cond [(pair? lst)
173 |          (if (ok? (car lst))
174 |              (loop count (cons (car lst) racc) (cdr lst))
175 |              (loop (add1 count) racc (cdr lst)))]
176 |         [else
177 |          (values rejected (reverse racc))]))
178 | 
179 | ;; let/let* absorption requires single-clause lets; unsafe otherwise
180 | ;; (changes scoping)
181 | (define-sexprw-tactic let-absorb-let*
182 |   (let ([$var:id $rhs]) (let* ($clauses:rest) $body:rest))
183 |   (let* ([$var $rhs] !NL $clauses) !NL $body))
184 | (define-sexprw-tactic let*-absorb-let
185 |   (let* ($clauses:rest) (let ([$var:id $rhs]) $body:rest))
186 |   (let* ($clauses !NL [$var $rhs]) !NL $body))
187 | 
188 | ' ; example for let-absorb-let*, let*-absorb-let
189 | (let ((x 1))
190 |   (let* ((y (f x))
191 |          (z (g x y)))
192 |     (let ((q (+ x y z)))
193 |       (h x y z))))
194 | 
195 | (define-sexprw-tactic begin-trivial
196 |   ;; See also let-splice, begin-splice
197 |   (begin $body)
198 |   $body)
199 | 
200 | ' ; example for begin-trivial
201 | (begin 5)
202 | 
203 | (define-sexprw-tactic match1-to-definition
204 |   (match $expr ($pattern $body:rest))
205 |   (let () !NL (match-define $pattern !SL $expr) !NL $body))
206 | 
207 | ' ; example for match1-to-definition
208 | (match (thing-position (current-thing))
209 |   [(point x y _)
210 |    (and (< XMIN x XMAX) (< YMIN y YMAX))])
211 | 
212 | ;; HO functions to for loops
213 | 
214 | (define-sexprw-nt list-expr
215 |   :attributes ($for-rhs)
216 |   (pattern (vector->list $e)
217 |            :with $for-rhs (in-vector $e))
218 |   (pattern (string->list $e)
219 |            :with $for-rhs (in-string $e))
220 |   (pattern (range $n)
221 |            :with $for-rhs (in-range $n))
222 |   (pattern $e
223 |            :with $for-rhs (in-list $e)))
224 | 
225 | (defmacro define-sexprw-*map-tactic (name map-sym for-sym)
226 |   `(define-sexprw-tactic ,name
227 |      (,map-sym (lambda ($arg:id ...) $body:rest) $lst:list-expr ...)
228 |      (,for-sym ((!@ [$arg $lst.$for-rhs] !NL) ...) !NL $body)))
229 | 
230 | (define-sexprw-*map-tactic map      map      for/list)
231 | (define-sexprw-*map-tactic for-each for-each for)
232 | (define-sexprw-*map-tactic ormap    ormap    for/or)
233 | (define-sexprw-*map-tactic andmap   andmap   for/and)
234 | 
235 | ' ; example for ormap
236 | (define (pointwise< xs ys)
237 |   (not (ormap (lambda (x y) (>= x y)) xs ys)))
238 | 
239 | ' ; example for map
240 | (define (frobble xs ys)
241 |   (map (lambda (x y) (bargle x y)) xs ys))
242 | 
243 | ' ; example of "optimization"
244 | (map (lambda (e) (add1 e)) (vector->list es))
245 | 
246 | (define-sexprw-tactic foldl
247 |   (foldl (lambda ($arg:id ... $accum:id) $body:rest) $init $lst ...)
248 |   (for/fold ([$accum $init]) !NL
249 |             ((!@ [$arg (in-list $lst)] !NL) ...) !NL
250 |     $body))
251 | 
252 | ' ; example for foldl
253 | (foldl (lambda (x y acc) (f x (g y acc) acc))
254 |        0
255 |        some-things
256 |        (append better-things worse-things))
257 | 
258 | ;; What about for-loop fusion or absorption?
259 | ;; (for/* ([$name (in-list (filter %pred %lst))]) %%body)
260 | ;; => (for/* ([$name (in-list $lst)]
261 | ;;            #:when (%pred $name))    ; unsafe: puts %pred in scope of $name
262 | ;;      %%body)
263 | 
264 | (define-sexprw-tactic build-list
265 |   (build-list $n (lambda ($arg:id) $body:rest))
266 |   (for/list ([$arg (in-range $n)]) !NL $body))
267 | 
268 | (define-sexprw-tactic for/sum-from-map
269 |   (apply + (map (lambda ($arg:id ...) $body:rest) $lst ...))
270 |   (for/sum ((!@ [$arg:id (in-list $lst)] !NL) ...) !NL $body))
271 | 
272 | (define-sexprw-tactic for/sum-from-for/list
273 |   (apply + (for/list $body:rest))
274 |   (for/sum $body))
275 | 
276 | (define-sexprw-tactic in-list-vector->list
277 |   (in-list (vector->list $e))
278 |   (in-vector $e))
279 | 
280 | ;; ============================================================
281 | ;; Definition rewritings
282 | 
283 | ;; Most of these are unsafe if applied in an expression context.
284 | 
285 | (setq sexprw-auto-definition-tactics
286 |       '(define-absorb-lambda
287 |          splice-begin
288 |          splice-letrec
289 |          splice-empty-let
290 |          define-case-lambda-sort-clauses
291 |          define-case-lambda-to-optionals
292 |          define-rest-to-optional
293 |          define-rest-to-optional2))
294 | 
295 | (define-sexprw-tactic define-absorb-lambda
296 |   (define $name:id (lambda ($arg ...) $body:rest))
297 |   (define ($name $arg ...) !NL $body))
298 | 
299 | ' ; example for define-absorb-lambda
300 | (define f
301 |   (lambda (x y [z (+ x y)])
302 |     ;; a comment
303 |     (displayln y)
304 |     (+ y 1)
305 |     ;; trailing comment
306 |     ))
307 | 
308 | (define-sexprw-tactic define-absorb-lambda/curry
309 |   (define $header (lambda ($arg ...) $body:rest))
310 |   (define ($header $arg ...) !NL $body))
311 | 
312 | (define-sexprw-tactic splice-begin
313 |   (begin $body:rest)
314 |   $body)
315 | 
316 | (define-sexprw-tactic splice-letrec
317 |   ;; Unsafe, changes scope of $names
318 |   (letrec (($name:id $rhs) ...) $body:rest)
319 |   (!@ (!@ (define $name !NL $rhs) !NL) ... $body))
320 | 
321 | (define-sexprw-tactic splice-empty-let
322 |   ;; Unsafe if %%body contains definitions: changes their scopes
323 |   (let () $body:rest)
324 |   $body)
325 | 
326 | ;; FIXME: would be better to have a case-lambda transformation, reuse
327 | ;; for define rhs
328 | (define-sexprw-tactic case-lambda-sort-clauses
329 |   (case-lambda (($var:id ...) $body:rest) ...)
330 |   :guard
331 |   (lambda (env)
332 |     ;; check no $var is a dot (means rest args)
333 |     ;; sort vars and bodies together by length of vars list
334 |     (cond ((not (sexprw-guard-no-dot env '$var))
335 |            nil)
336 |           ;; If already sorted, tactic does not apply (else gets stuck
337 |           ;; repeating this)
338 |           ((let ((var-entries (cdr (sexprw-env-ref env '$var)))
339 |                  (sorted t))
340 |              (while (and (consp var-entries) (consp (cdr var-entries)))
341 |                (unless (< (length (car var-entries))
342 |                           (length (cadr var-entries)))
343 |                  (setq sorted nil))
344 |                (setq var-entries (cdr var-entries)))
345 |              sorted)
346 |            ;; (message "clauses already sorted")
347 |            nil)
348 |           (t
349 |            (let ((clauses nil)
350 |                  (var-entries (cdr (sexprw-env-ref env '$var)))
351 |                  (bodies (cdr (sexprw-env-ref env '$body))))
352 |              (while var-entries
353 |                (setq clauses (cons (cons (car var-entries) (car bodies))
354 |                                    clauses))
355 |                (setq var-entries (cdr var-entries))
356 |                (setq bodies (cdr bodies)))
357 |              (setq clauses
358 |                    (sort clauses
359 |                          (lambda (a b)
360 |                            ;; use >, then reverse-split result
361 |                            (> (length (car a)) (length (car b))))))
362 |              (dolist (clause clauses)
363 |                (setq var-entries (cons (car clause) var-entries))
364 |                (setq bodies (cons (cdr clause) bodies)))
365 |              (list `(($sorted-var rep ,@var-entries)
366 |                      ($sorted-body rep ,@bodies)
367 |                      ,@env))))))
368 |   ;; template:
369 |   (case-lambda !NL
370 |     (!@ [($sorted-var ...) !NL $sorted-body] !NL) ...))
371 | 
372 | (define-sexprw-tactic define-case-lambda-sort-clauses
373 |   (define $name:id $body:case-lambda-sort-clauses)
374 |   (define $name !NL $body.$out))
375 | 
376 | (define-sexprw-tactic define-case-lambda-to-optionals
377 |   (define $name:id
378 |     (case-lambda
379 |      (($arg:id ...) ($uname:id $arg:id ... $newarg)) ...
380 |      (($farg:id ...) $body:rest)))
381 |   :guard
382 |   (lambda (env)
383 |     (let ((failed nil)
384 |           (required-arg-count nil)
385 |           ($name-entry (sexprw-env-ref env '$name))
386 |           ($uname-entries (cdr (sexprw-env-ref env '$uname)))
387 |           ($args-entries (cdr (sexprw-env-ref env '$arg)))
388 |           ($fargs-entry (sexprw-env-ref env '$farg)))
389 |       ;; each $uname is $name (nonlinear pvars don't work here,
390 |       ;; different depths :(
391 |       (dolist ($uname-entry $uname-entries)
392 |         (unless (sexprw-entry-equal $uname-entry $name-entry)
393 |           ;; (message "$uname %S failed to match $name %S"
394 |           ;;          $uname-entry $name-entry)
395 |           (sexprw-fail `(...-to-optionals name/uname uname-entry= ,uname-entry name-entry= ,name-entry))
396 |           (setq failed t)))
397 |       ;; each arglist is one shorter than next ($arg names don't have
398 |       ;; to match)
399 |       (let ((all-arg-entries `(,@$args-entries ,$fargs-entry)))
400 |         ;; 1- for 'rep header
401 |         (setq required-arg-count (1- (length (car all-arg-entries))))
402 |         (while (and (consp all-arg-entries) (consp (cdr all-arg-entries)))
403 |           (let ((arg-entries1 (car all-arg-entries))
404 |                 (arg-entries2 (cadr all-arg-entries)))
405 |             (setq all-arg-entries (cdr all-arg-entries))
406 |             (unless (= (1+ (length arg-entries1)) (length arg-entries2))
407 |               ;; (message "bad arg lengths")
408 |               (setq failed t)))))
409 |       ;; done by pattern: each clause applies $uname to args, plus one
410 |       ;; new arg at end
411 |       ;; split $farg into $required-arg and $optional-arg
412 |       (let ((farg-entries (cdr $fargs-entry))
413 |             (r-required-args nil))
414 |         (dotimes (_i required-arg-count)
415 |           (setq r-required-args (cons (car farg-entries) r-required-args))
416 |           (setq farg-entries (cdr farg-entries)))
417 |         (if failed
418 |             nil
419 |           (list `(($required-arg rep ,@(reverse r-required-args))
420 |                   ($optional-arg rep ,@farg-entries)
421 |                   ,@env))))))
422 |   ;; template:
423 |   (define ($name $required-arg ... (!SQ $optional-arg $newarg) ...) !NL
424 |     $body))
425 | 
426 | ' ; example for define-case-lambda-sort-clauses and
427 |   ; define-case-lambda-to-optionals
428 | (define f
429 |   (case-lambda
430 |     [(x) (f x 2)]
431 |     [() (f 1)]
432 |     [(x y) (f x y)]))
433 | 
434 | (define-sexprw-tactic define-rest-to-optional
435 |   ;; Unsafe if $rest used elsewhere in $body
436 |   ;; Also, see guard
437 |   (define ($name:id $arg:id ... \. $rest:id)
438 |     (let (($optional-arg:id (if (null? $rest:id) $default (car $rest:id))))
439 |       $body:rest))
440 |   :guard
441 |   (lambda (env)
442 |     ;; If $default = $rest, rewrite to null
443 |     ;; Unsafe if $default *contains* $rest
444 |     (if (sexprw-entry-equal (sexprw-env-ref env '$default)
445 |                             (sexprw-env-ref env '$rest))
446 |         (list (cons (cons '$default (sexprw-template 'null env)) env))
447 |       (list env)))
448 |   (define ($name $arg ... [$optional-arg $default]) !NL $body))
449 | 
450 | (define-sexprw-tactic define-rest-to-optional2
451 |   ;; Unsafe if $rest used elsewhere in $body
452 |   ;; Also, see guard
453 |   (define ($name:id $arg:id ... \. $rest:id)
454 |     (let (($optional-arg:id (if (pair? $rest:id) (car $rest:id) $default)))
455 |       $body:rest))
456 |   :guard
457 |   (lambda (env)
458 |     ;; If $default = $rest, rewrite to null
459 |     ;; Unsafe if $default *contains* $rest
460 |     (if (sexprw-entry-equal (sexprw-env-ref env '$default)
461 |                             (sexprw-env-ref env '$rest))
462 |         (list (cons (cons '$default (sexprw-template 'null env)) env))
463 |       (list env)))
464 |   (define ($name $arg ... [$optional-arg $default]) !NL $body))
465 | 
466 | ' ; example for define-rest-to-optionals (from SXML)
467 | (define (ddo:ancestor test-pred? . num-ancestors)
468 |   (let ((num-anc (if (null? num-ancestors) 0 (car num-ancestors))))
469 |     (do-stuff-with test-pred? num-anc)))
470 | 
471 | 
472 | ;; ============================================================
473 | ;; Specialized rewritings
474 | ;; Need to be explicitly triggered.
475 | 
476 | (define-sexprw-tactic split-let
477 |   (let ($clause $more-clauses:rest) $body:rest)
478 |   (let ($clause) !NL (let ($more-clauses) !NL $body)))
479 | 
480 | (define-sexprw-tactic split-let*
481 |   ;; Occasionally useful for eg define-rest-to-optionals
482 |   (let* ($clause $more-clauses:rest) $body:rest)
483 |   (let ($clause) !NL (let* ($more-clauses) !NL $body)))
484 | 
485 | ' ; example for split-let*
486 | (define (blah . rest)
487 |   (let* ((rest (if (null? rest) 0 (car rest)))
488 |          (more (add1 rest)))
489 |     (body)))
490 | 
491 | (define-sexprw-nt define-like-kw
492 |   (pattern define)
493 |   (pattern define-syntax))
494 | 
495 | (define-sexprw-tactic define-split-lambda
496 |   ;; Inverse of define-absorb-lambda
497 |   ($define:define-like-kw ($name:id $arg ...) $body:rest)
498 |   ($define $name !NL (lambda ($arg ...) !NL $body)))
499 | 
500 | ' ; example for define-split-lambda
501 | (define (f x) (or x 1))
502 | 
503 | ' ; another example for define-split-lambda
504 | (define-syntax (f x) (or x 1))
505 | 
506 | ;; ----
507 | 
508 | (define-sexprw-tactic beta-to-let
509 |   ((lambda ($arg:id ...) $body:rest) $val ...)
510 |   (let ((!@ [$arg $val] !SL) ...) !SL $body))
511 | 
512 | ' ;; example for beta-to-let
513 | ((lambda (x)
514 |    (+ x 1))
515 |  (- 13 1))
516 | 
517 | (define-sexprw-tactic eta-reduce
518 |   ;; Unsafe if $e has side-effects or may not terminate
519 |   (lambda ($arg ...) ($e $arg ...))
520 |   $e)
521 | 
522 | ' ; example for eta-reduce
523 | (lambda (x y z) (f x y z))
524 | 
525 | (define-sexprw-tactic eta-expand
526 |   $expr
527 |   :guard
528 |   (lambda (env)
529 |     (let ((argn (read-number "Number of arguments: " 1)))
530 |       (unless (and (integerp argn) (>= argn 0))
531 |         (error "Bad number of arguments: %S" argn))
532 |       (let ((args
533 |              (cond ((= argn 0)
534 |                     nil)
535 |                    ((= argn 1)
536 |                     (list (sexprw-template 'x nil)))
537 |                    (t
538 |                     (let ((rargs nil))
539 |                       (dotimes (i argn)
540 |                         (push (sexprw-template (intern (format "x%d" (1+ i))) nil)
541 |                               rargs))
542 |                       (reverse rargs))))))
543 |         (list (cons (cons '$arg (cons 'rep args)) env)))))
544 |   ;; template
545 |   (lambda ($arg ...) !SL ($expr $arg ...)))
546 | 
547 | ' ; example for eta-expand
548 | add1
549 | 
550 | ' ; another example for eta-expand
551 | (compose foo
552 |          bar)
553 | 
554 | (define-sexprw-tactic invmap
555 |   (for/list ([$x (in-list $xs)]) ($fn $x))
556 |   (map $fn:id $xs))
557 | 
558 | ' ; example for invmap
559 | (for/list ([x (in-list xs)]) (f x))
560 | 
561 | (defun sexprw-block-from-text (text)
562 |   (list 'block text t 0 0 nil nil))
563 | 
564 | (define-sexprw-tactic intro-function
565 |   $expr
566 |   :guard
567 |   (lambda (env)
568 |     (let ((header (read-string "Enter function header:")))
569 |       (list (cons (cons '$header (sexprw-block-from-text header)) env))))
570 |   (!SPLICE
571 |    (define $header !SL $expr) !NL
572 |    $header))
573 | 
574 | ' ; example for intro-function; type "(f x)"
575 | (+ x 1)
576 | 
577 | ;; ============================================================
578 | 
579 | (define-sexprw-nt error-call
580 |   (pattern (error $arg:rest)))
581 | 
582 | (define-sexprw-tactic if-error-when
583 |   (if $c $e:error-call $body)
584 |   (!SPLICE (when $c !SL $e) !NL $body))
585 | 
586 | (define-sexprw-tactic if-error-unless
587 |   (if $c $body $e:error-call)
588 |   (!SPLICE (unless $c !SL $e) !NL $body))
589 | 
590 | 
591 | ';
592 | (let ()
593 |   (if (bad?)
594 |       (error 'who "it's bad")
595 |       (handle the thing)))
596 | 
597 | (provide 'racket-rewrites)
598 | ;;; racket-rewrites.el ends here.
599 | 


--------------------------------------------------------------------------------
/sexp-rewrite.el:
--------------------------------------------------------------------------------
   1 | ;;; sexp-rewrite.el --- pattern-based rewriting of sexp-structured code  -*- lexical-binding:t -*-
   2 | 
   3 | ;; Copyright 2013-2019 Ryan Culpepper.
   4 | ;; Released under the terms of the GPL version 3 or later;
   5 | ;; see the text after `sexprw-legal-notice' for details.
   6 | 
   7 | ;; Version: 0.04
   8 | 
   9 | (defconst sexprw-copyright    "Copyright 2013-2019 Ryan Culpepper")
  10 | (defconst sexprw-version      "0.04")
  11 | (defconst sexprw-author-name  "Ryan Culpepper")
  12 | (defconst sexprw-author-email "ryanc@racket-lang.org")
  13 | (defconst sexprw-web-page     "https://github.com/rmculpepper/sexp-rewrite")
  14 | 
  15 | (defconst sexprw-legal-notice
  16 |   "This program is free software: you can redistribute it and/or modify
  17 | it under the terms of the GNU General Public License as published by
  18 | the Free Software Foundation, either version 3 of the License, or (at
  19 | your option) any later version.
  20 | 
  21 | This program is distributed in the hope that it will be useful,
  22 | but WITHOUT ANY WARRANTY; without even the implied warranty of
  23 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  24 | General Public License at http://www.gnu.org/licenses/gpl-3.0.html
  25 | for more details.")
  26 | 
  27 | ;;; Commentary:
  28 | 
  29 | ;; ============================================================
  30 | ;; TO DO
  31 | 
  32 | ;; short term
  33 | ;; - make sure sugared pattern lang is complete for core pattern lang
  34 | ;; - automated testing
  35 | ;; - documentation, rationale, etc
  36 | ;; - documentation for individual tactics ??
  37 | ;; - support COMMENT var kind
  38 | ;; - better comment handling (custom regexp? may need hook)
  39 | ;; - improve guard support 
  40 | ;;   - require guard extends env?
  41 | ;;   - add ranges back to block matches
  42 | ;;     - might be useful for recursive processing ??
  43 | ;; - package nicely in Emacs idiom
  44 | ;;   - minor mode ??
  45 | ;;   - make sure keybindings are added politely
  46 | ;;   - customization options ??
  47 | ;; - tweak whitespace handling ??
  48 | ;; - hook for scan-sexps replacement
  49 | ;; - hook for scan-whitespace, scan-comments replacements
  50 | ;; - custom var to disable square brackets (use parens instead)
  51 | ;; - build "tactic apropos"---search by literals in tactic pattern & template
  52 | ;; - more interactive/flexible rewriting
  53 | ;;   - eg, move let/let*/letrec bindings to <interactive point>
  54 | ;; - put rewrite rules in "bundles", and enable different "bundles" for
  55 | ;;   different major modes (scheme-mode, racket-mode, emacs-lisp-mode, ...)
  56 | 
  57 | ;; long term
  58 | ;; - port to DrRacket
  59 | ;; - use DrRacket semantic info (eg, freevars) for safety
  60 | 
  61 | ;; ============================================================
  62 | ;; Misc notes
  63 | 
  64 | ;; Matching functions, etc return nil on failure, only raise error on
  65 | ;; bad input (illegal pattern, etc).
  66 | 
  67 | ;; ============================================================
  68 | ;; Keybindings
  69 | 
  70 | ;;; Code:
  71 | 
  72 | (defvar sexprw-mode-map
  73 |   (let ((mainmap (make-sparse-keymap))
  74 |         (map (make-sparse-keymap)))
  75 |     (define-key mainmap (kbd "C-c C-s") map)
  76 | 
  77 |     (define-key map "e" 'sexprw-auto-expression)
  78 |     (define-key map "d" 'sexprw-auto-definition)
  79 |     (define-key map "x" 'sexprw-execute-tactic)
  80 |     (define-key map "s" 'sexprw-search-pattern)
  81 |     (define-key map "i" 'sexprw-search-rewrite)
  82 |     (define-key map "[" 'sexprw-squarify)
  83 |     (define-key map "(" 'sexprw-roundify)
  84 | 
  85 |     (define-key map "k" 'sexprw-kill-next-sexpagon-sexp)
  86 |     (define-key map "w" 'sexprw-kill-sexpagon-region)
  87 |     (define-key map "y" 'sexprw-yank-sexpagon)
  88 | 
  89 |     (define-key map (kbd "M-SPC") 'sexprw-collapse-space/move-sexps)
  90 |     (define-key map [tab] 'sexprw-indent-rigidly)
  91 | 
  92 |     (define-key map (kbd "r e")
  93 |       (lambda () (interactive) (sexprw-auto-expression 100)))
  94 |     (define-key map (kbd "r d")
  95 |       (lambda () (interactive) (sexprw-auto-definition 100)))
  96 |     mainmap))
  97 | 
  98 | (defvar sexprw-auto-expression-tactics nil
  99 |   "List of tactics tried by `sexprw-auto-expression'.")
 100 | (defvar sexprw-auto-definition-tactics nil
 101 |   "List of tactics tried by `sexprw-auto-definition'.")
 102 |   
 103 | (defvar sexprw-tactic-history nil)
 104 | (defvar sexprw-pattern-history nil)
 105 | (defvar sexprw-template-history nil)
 106 | 
 107 | (defgroup sexprw nil
 108 |   "Customization options for sexp-rewrite."
 109 |   :group 'scheme)
 110 | 
 111 | (defcustom sexprw-disabled-auto-tactics nil
 112 |   "Tactics that should not be run automatically.
 113 | Affects only `sexprw-auto-expression' and `sexprw-auto-definition';
 114 | disabled tactics can still be run via `sexprw-execute-tactic', etc."
 115 |   :type '(repeat symbol))
 116 | 
 117 | ;;;###autoload
 118 | (define-minor-mode sexprw-mode
 119 |   "Minor mode for pattern-based rewrite of sexp-structured code."
 120 |   ;; Implicitly activates sexprw-mode-map when enabled.
 121 |   :init-value nil)
 122 | 
 123 | ;; FIXME: This should likely be in an emacs-lisp-rewrite.el with corresponding
 124 | ;; rewrite rules.
 125 | ;;;###autoload
 126 | (add-hook 'emacs-lisp-mode-hook #'sexprw-mode)
 127 | ;;;###autoload
 128 | (add-hook 'scheme-mode-hook #'sexprw-mode)
 129 | 
 130 | (defun sexprw-disable-tactic (tactic-name)
 131 |   (interactive
 132 |    (list (sexprw-read-tactic-from-minibuffer)))
 133 |   (push tactic-name sexprw-disabled-auto-tactics))
 134 | 
 135 | (defun sexprw-enable-tactic (tactic-name)
 136 |   (interactive
 137 |    (list (sexprw-read-tactic-from-minibuffer)))
 138 |   (setq sexprw-disabled-auto-tactics
 139 |         (delete tactic-name sexprw-disabled-auto-tactics)))
 140 | 
 141 | ;; ============================================================
 142 | ;; Debugging and diagnostics
 143 | 
 144 | (defvar sexprw-current-operation nil
 145 |   "Name of currently executing operation.")
 146 | 
 147 | (defvar sexprw-failure-info nil
 148 |   "Information about last sexp-rewrite failure(s).")
 149 | 
 150 | (defun sexprw-fail (info)
 151 |   (push (cons sexprw-current-operation (cons (point) info)) sexprw-failure-info)
 152 |   nil)
 153 | 
 154 | (defun sexprw-show-failure-info ()
 155 |   (interactive)
 156 |   (message "%S" sexprw-failure-info))
 157 | 
 158 | (define-error 'sexprw-template-error "Error instantiating template")
 159 | 
 160 | ;; ============================================================
 161 | ;; Running tactics
 162 | 
 163 | (defun sexprw-auto-expression (&optional times)
 164 |   "Run the default sexp-rewrite tactics for expressions.
 165 | Customizable via the variable `sexprw-auto-expression-tactics'."
 166 |   (interactive "p")
 167 |   (sexprw-execute-tactics sexprw-auto-expression-tactics times t))
 168 | (defun sexprw-auto-definition (&optional times)
 169 |   "Run the default sexp-rewrite tactics for definitions.
 170 | Customizable via the variable `sexprw-auto-definition-tactics'."
 171 |   (interactive "p")
 172 |   (sexprw-execute-tactics sexprw-auto-definition-tactics times t))
 173 | 
 174 | (defun sexprw-execute-tactic (tactic-name &optional times0)
 175 |   "Read sexprw-rewrite tactic, then try to execute it."
 176 |   (interactive
 177 |    (list (sexprw-read-tactic-from-minibuffer)
 178 |          (prefix-numeric-value current-prefix-arg)))
 179 |   (sexprw-execute-tactics (list tactic-name) times0 nil))
 180 | 
 181 | (defun sexprw-execute-tactics (tactic-names times0 respect-disabled)
 182 |   (setq sexprw-failure-info nil)
 183 |   (let ((rused (sexprw-run-tactics-until-success tactic-names times0)))
 184 |     (cond ((consp rused)
 185 |            (cond ((= (length rused) 1)
 186 |                   (message "Applied tactic %s" (car rused)))
 187 |                  (t (message "Applied tactics: %s" (reverse rused)))))
 188 |           (t
 189 |            (cond ((= (length tactic-names) 1)
 190 |                   (message "Tactic %s not applicable" (car tactic-names)))
 191 |                  (t (message "No applicable tactic")))))))
 192 | 
 193 | ;; sexprw-run-tactic* functions return list of successful tactics in
 194 | ;; reverse order
 195 | 
 196 | (defun sexprw-run-tactic (tactic-name)
 197 |   (let* ((nt-val (sexprw-nt-value tactic-name))
 198 |          (nt-pattern (nth 1 nt-val)))
 199 |     (and (let ((sexprw-current-operation `(tactic ,tactic-name))) ; fluid-let
 200 |            (sexprw-rewrite/ast nt-pattern '(VAR $out)))
 201 |          (list tactic-name))))
 202 | 
 203 | (defun sexprw-run-tactics-until-success (tactics &optional times0 respect-disabled)
 204 |   (let ((times times0)
 205 |         success
 206 |         rused)
 207 |     (while (> times 0)
 208 |       (setq times (1- times))
 209 |       (setq success nil)
 210 |       (dolist (tactic tactics)
 211 |         (unless (memq tactic sexprw-disabled-auto-tactics)
 212 |           (unless success
 213 |             (when (sexprw-run-tactic tactic)
 214 |               (setq success t)
 215 |               (setq rused (cons tactic rused))))))
 216 |       (unless success (setq times 0)))
 217 |     rused))
 218 | 
 219 | ;; ============================================================
 220 | ;; Rewriting
 221 | 
 222 | (defun sexprw-rewrite (pattern template &optional guard)
 223 |   (interactive
 224 |    (list 
 225 |     (read-from-minibuffer "Pattern: " nil nil t 'sexprw-pattern-history)
 226 |     (read-from-minibuffer "Template: " nil nil t 'sexprw-template-history)))
 227 |   ;; (message "parsed pattern = %S" (sexprw-desugar-pattern pattern nil))
 228 |   (sexprw-rewrite/ast (sexprw-desugar-pattern pattern nil)
 229 |                       (sexprw-desugar-pattern template t)
 230 |                       guard))
 231 | 
 232 | (defun sexprw-rewrite/ast (pattern template &optional guard)
 233 |   (save-excursion
 234 |     (sexprw-skip-whitespace)
 235 |     (let* ((init-point (point))
 236 |            ;; puts point after pattern match
 237 |            (replacement (sexprw-compute-rewrite/ast pattern template guard)))
 238 |       (and replacement
 239 |            (progn
 240 |              (delete-and-extract-region init-point (point))
 241 |              (sexprw-emit replacement)
 242 |              t)))))
 243 | 
 244 | (defun sexprw-compute-rewrite/ast (pattern template &optional guard)
 245 |   ;; (message "pattern = %S" pattern)
 246 |   ;; (message "template = %S" template)
 247 |   (let ((env (sexprw-match pattern)))
 248 |     ;; (message "point = %S" (point))
 249 |     ;; (message "env = %S" env)
 250 |     (and env
 251 |          (sexprw-check-nonlinear-patterns (car env))
 252 |          (let ((env* (if guard (funcall guard (car env)) env)))
 253 |            ;; (message "guarded env = %S" env*)
 254 |            (and (or env*
 255 |                     (sexprw-fail `(guard env= ,env)))
 256 |                 (let ((preoutput
 257 |                        (condition-case error-info
 258 |                            (sexprw-template* template (car env*))
 259 |                          (template-error 
 260 |                           (sexprw-fail `(template ,error-info guard-env=
 261 |                                                   ,(car env*)))))))
 262 |                   ;; (message "preoutput = %S" preoutput)
 263 |                   (and preoutput
 264 |                        (let ((output
 265 |                               (condition-case error-info
 266 |                                   (sexprw-output preoutput)
 267 |                                 (template-error
 268 |                                  (sexprw-fail `(output ,error-info))))))
 269 |                          ;; (message "output = %S" output)
 270 |                          output))))))))
 271 | 
 272 | ;; FIXME: here's another quadratic function...
 273 | (defun sexprw-check-nonlinear-patterns (env0)
 274 |   (let ((ok t)
 275 |         (env env0))
 276 |     (while (and env ok)
 277 |       (let* ((entry1 (car env))
 278 |              (key1 (car entry1))
 279 |              (rest-env (cdr env)))
 280 |         (setq env rest-env)
 281 |         (let ((entry2 (assq key1 rest-env)))
 282 |           (when entry2
 283 |             (unless (sexprw-entry-equal (cdr entry1) (cdr  entry2))
 284 |               (sexprw-fail `(nonlinear-pvar ,key1 env= ,env0))
 285 |               (setq ok nil))))))
 286 |     ok))
 287 | 
 288 | (defun sexprw-entry-equal (a b)
 289 |   (cond ((and (eq (car a) 'rep) (eq (car b) 'rep)
 290 |               (= (length a) (length b)))
 291 |          (let ((as (cdr a)) 
 292 |                (bs (cdr b))
 293 |                (ok t))
 294 |            (while (and as bs)
 295 |              (setq ok (sexprw-entry-equal (car as) (car bs)))
 296 |              (setq as (cdr as))
 297 |              (setq bs (cdr bs)))
 298 |            ok))
 299 |         ((and (eq (car a) 'block) (eq (car b) 'block))
 300 |          ;; FIXME: could compare sexpagons (if exist), slightly more equalities
 301 |          (equal (sexprw-block-text a)
 302 |                 (sexprw-block-text b)))
 303 |         (t nil)))
 304 | 
 305 | ;; ============================================================
 306 | ;; Pretty patterns and templates
 307 | 
 308 | ;; PP ::= symbol         ~ (quote symbol)
 309 | ;;      | $name:nt       ~ (VAR $name nt)      ; sigil is part of pvar name
 310 | ;;      | $name          ~ (VAR $name sexp)
 311 | ;;      | (PP*)          ~ (LIST P*)
 312 | ;;      | (!@ PP*)       ~ (SPLICE P*)
 313 | ;;      | (!SPLICE PP*)  ~ (SPLICE P*)
 314 | ;;      | PP ...         ~ (pREP P <Pk>)       ; <Pk> is patterns that follow,
 315 | ;;                                             ; grouped as splice
 316 | ;;      | (!OR PP*)      ~ (OR P*)
 317 | ;;      | (!AND PP*)     ~ (AND P*)
 318 | ;;      | (!GUARD P expr)~ (GUARD P expr)
 319 | 
 320 | ;; PT ::= like PP, with following additions and replacements:
 321 | ;;      | [ PT* ]        ~ (SQLIST T*)
 322 | ;;      | (!SQ PT*)      ~ (SQLIST T*)
 323 | ;;      | !NL            ~ (NL)
 324 | ;;      | !SP            ~ (SP)
 325 | ;;      | !SL            ~ (SL)
 326 | ;;      | !NOSP          ~ (NONE)
 327 | ;;      | (!REP PT vars) ~ (tREP T vars)
 328 | ;;      | PT ...         ~ (tREP T nil)        ; vars=nil means "auto"
 329 | 
 330 | (defun sexprw-desugar-pattern (pretty template)
 331 |   (cond ((null pretty)
 332 |          '(LIST))
 333 |         ((symbolp pretty)
 334 |          (sexprw-desugar-pattern-symbol pretty template))
 335 |         ((vectorp pretty)
 336 |          (if template
 337 |              (cons 'SQLIST (sexprw-desugar-pattern-list (append pretty nil) template))
 338 |            (cons 'LIST (sexprw-desugar-pattern-list (append pretty nil) template))))
 339 |         ((not (consp pretty))
 340 |          (error "Bad %s: %S" (if template "template" "pattern") pretty))
 341 |         ((memq (car pretty) '(!@ !SPLICE))
 342 |          (cons 'SPLICE (sexprw-desugar-pattern-list (cdr pretty) template)))
 343 |         ((eq (car pretty) '!SQ)
 344 |          (if template
 345 |              (cons 'SQLIST (sexprw-desugar-pattern-list (cdr pretty) template))
 346 |              (error "Bad pattern (!SQ not allowed): %S" pretty)))
 347 |         ((eq (car pretty) '!REP)
 348 |          (if template
 349 |              (list 'tREP (sexprw-desugar-pattern (nth 1 pretty)) (nth 2 pretty))
 350 |            (error "Bad pattern (!REP not allowed): %S" pretty)))
 351 |         ((eq (car pretty) '!OR)
 352 |          (if template
 353 |              (error "Bad template (!OR not allowed): %S" pretty)
 354 |            (cons 'OR
 355 |                  (mapcar (lambda (p) (sexprw-desugar-pattern p nil))
 356 |                          (cdr pretty)))))
 357 |         ((eq (car pretty) '!AND)
 358 |          (if template
 359 |              (error "Bad template (!AND not allowed): %S" pretty)
 360 |            (cons 'AND
 361 |                  (if (consp (cdr pretty))
 362 |                      (cons (sexprw-desugar-pattern (cadr pretty) nil)
 363 |                            (mapcar (lambda (p) (sexprw-desugar-pattern p nil))
 364 |                                    (cddr pretty)))
 365 |                    nil))))
 366 |         ((eq (car pretty) '!GUARD)
 367 |          (if template
 368 |              (error "Bad template (!GUARD not allowed): %S" pretty)
 369 |            (let* ((subpattern (sexprw-desugar-pattern (nth 1 pretty) nil))
 370 |                   (guard (nth 2 pretty)))
 371 |              (unless (functionp guard)
 372 |                (error "Bad template: guard is not a function: %S" pretty))
 373 |              (list 'GUARD subpattern guard))))
 374 |         (t ; list
 375 |          (cons 'LIST (sexprw-desugar-pattern-list pretty template)))))
 376 | 
 377 | (defun sexprw-desugar-pattern-symbol (pretty template)
 378 |   (let ((name (symbol-name pretty)))
 379 |     (cond ((and template (eq pretty '!NL))
 380 |            '(NL))
 381 |           ((and template (eq pretty '!SP))
 382 |            '(SP))
 383 |           ((and template (eq pretty '!NOSP))
 384 |            '(NONE))
 385 |           ((and template (eq pretty '!SL))
 386 |            '(SL))
 387 |           ((eq pretty '...)
 388 |            (error "Misplaced ellipses: %S" pretty))
 389 |           ((string-match "^[!]" name)
 390 |            (error "Bad symbol in %s (reserved): %S"
 391 |                   (if template "template" "pattern")
 392 |                   pretty))
 393 |           ((string-match "^[$][_[:alpha:]][^:]*$" name)
 394 |            (if template
 395 |                `(VAR ,pretty)
 396 |              `(VAR ,pretty sexp)))
 397 |           ((string-match "^\\([$][_[:alpha:]][^:]*\\):\\([[:alpha:]].*\\)$" name)
 398 |            (let ((var (intern (match-string 1 name)))
 399 |                  (nt (intern (match-string 2 name))))
 400 |              (when nil ;; too early, prevents mutually recursive nts, forward refs, etc.
 401 |                (unless (sexprw-nt-symbolp nt)
 402 |                  (error "Bad pattern variable, no such sexpr-rewrite nonterminal: %S" pretty)))
 403 |              `(VAR ,var ,nt)))
 404 |           ((string-match "^[$]" name)
 405 |            (error "Bad pattern variable: %S" pretty))
 406 |           (t `(quote ,pretty)))))
 407 | 
 408 | (defun sexprw-desugar-pattern-list (pretty template)
 409 |   ;; Note: *not* same as (mapcar sexprw-desugar-pattern ....), 
 410 |   ;; because handles ellipses.
 411 |   (let ((rpretty (reverse pretty))
 412 |         (accum nil)
 413 |         (dots nil))
 414 |     (while rpretty
 415 |       (let ((p1 (car rpretty)))
 416 |         (setq rpretty (cdr rpretty))
 417 |         (cond ((eq p1 '...)
 418 |                (when dots (error "Repeated ellipses in pattern: %S" pretty))
 419 |                (setq dots t))
 420 |               (t
 421 |                (let ((pp1 (sexprw-desugar-pattern p1 template)))
 422 |                  (when dots
 423 |                    (setq dots nil)
 424 |                    (cond (template
 425 |                           (setq pp1 (list 'tREP pp1 nil)))
 426 |                          (t
 427 |                           (setq pp1 (list 'pREP pp1 (cons 'SPLICE accum)))
 428 |                           (setq accum nil))))
 429 |                  (push pp1 accum))))))
 430 |     (when dots (error "Misplaced dots at beginning of pattern: %S" pretty))
 431 |     accum))
 432 | 
 433 | ;; ============================================================
 434 | ;; Core patterns
 435 | 
 436 | ;; P ::= (LIST P*)
 437 | ;;     | (SPLICE P*)
 438 | ;;     | (quote symbol)
 439 | ;;     | (VAR symbol nt)
 440 | ;;     | (pREP P Pk)
 441 | ;;     | (AND P*)
 442 | ;;     | (OR P*)
 443 | ;;     | (GUARD P expr)
 444 | ;;
 445 | ;; Matching builds an alist mapping pvar symbols to EnvValue
 446 | ;; EnvValue ::= Block
 447 | ;;            | (list 'rep EnvValue)          ; representing depth>0 list
 448 | ;;            | (list 'pre PreOutput)         ; representing computed output
 449 | ;;
 450 | ;; (pREP P Pk) means "P ... Pk": match as many P as possible s.t. still
 451 | ;; possible to match Pk afterwards (then commit). Handling together
 452 | ;; avoids (non-local) backtracking while supporting non-trivial Pks.
 453 | 
 454 | ;; FIXME (or not): doesn't handle dotted-pair notation
 455 | 
 456 | ;; TODO: support IMPURITY as kind, matches non-whitespace stuff
 457 | ;; between (point) and next sexp.
 458 | 
 459 | (defconst sexprw-all-whitespace-re "[[:space:]\n]*")
 460 | 
 461 | (defconst sexprw-pure-atom-re
 462 |   ;; Note: vague approximation, doesn't distinguish numbers from symbols,
 463 |   ;; doesn't support \ and | escapes, etc, doesn't support Unicode chars.
 464 |   ;; FIXME: use [:alpha:] to capture more chars (Unicode) ???
 465 |   ;; FIXME: includes dot ?
 466 |   ;; FIXME: should be predicate, not regexp
 467 |   "^[-~!@$^&*_+=:./<>?a-zA-Z#0-9]+$")
 468 | 
 469 | (defun sexprw-match (pattern)
 470 |   "Matches the sexp starting at point against core PATTERN,
 471 | returning an \(list ENV) mapping the pattern variables of
 472 | PATTERN to fragments, or nil on failure.  Advances point to end
 473 | of matched term(s)."
 474 |   ;; (message "matching (%S): %S" (point) pattern)
 475 |   (cond ((not (consp pattern))
 476 |          (error "Bad pattern: %s" pattern))
 477 |         ((eq (car pattern) 'quote)
 478 |          ;; Note: grabs pure-sexp, checks contains symbol
 479 |          (let ((next (sexprw-grab-next-sexp t)))
 480 |            (and (or next
 481 |                     (sexprw-fail `(match quote pure-sexp)))
 482 |                 (let ((pure-text (sexprw-block-pure-text next)))
 483 |                   (and (or (string-match sexprw-pure-atom-re pure-text)
 484 |                            (sexprw-fail `(match quote is-symbol)))
 485 |                        (or (equal pure-text (symbol-name (cadr pattern)))
 486 |                            (sexprw-fail
 487 |                             `(match quote equal
 488 |                                     ,(symbol-name (cadr pattern)))))
 489 |                        (list nil))))))
 490 |         ((eq (car pattern) 'VAR)
 491 |          (sexprw-match-var (nth 1 pattern) (nth 2 pattern)))
 492 |         ((eq (car pattern) 'LIST)
 493 |          (sexprw-match-list (cdr pattern)))
 494 |         ((eq (car pattern) 'SPLICE)
 495 |          (sexprw-match-patterns (cdr pattern)))
 496 |         ((eq (car pattern) 'pREP)
 497 |          (sexprw-match-rep (nth 1 pattern) (nth 2 pattern)))
 498 |         ((eq (car pattern) 'OR)
 499 |          (let ((init-point (point))
 500 |                (result nil)
 501 |                (rfailinfos nil)
 502 |                (alternatives (cdr pattern)))
 503 |            (while (and (consp alternatives) (not result))
 504 |              (goto-char init-point)
 505 |              (let ((sexprw-failure-info nil)) ;; fluid-let
 506 |                (setq result (sexprw-match (car alternatives)))
 507 |                (push sexprw-failure-info rfailinfos))
 508 |              (setq alternatives (cdr alternatives)))
 509 |            (or result
 510 |                (sexprw-fail `(match or inners= ,(reverse rfailinfos))))))
 511 |         ((eq (car pattern) 'AND)
 512 |          (let ((init-point (point))
 513 |                (renvs nil)
 514 |                (ok t)
 515 |                (first-time t)
 516 |                (conjuncts (cdr pattern)))
 517 |            ;; Use restriction and looking-at (below) to ensure that
 518 |            ;; all conjuncts match the same sexps.
 519 |            ;; In other words, first conjunct constrains what
 520 |            ;; subsequent conjuncts can see.
 521 |            (save-restriction
 522 |              (while (and ok (consp conjuncts))
 523 |                (goto-char init-point)
 524 |                (let ((result (sexprw-match (car conjuncts))))
 525 |                  (cond ((and result
 526 |                              (or first-time
 527 |                                  (looking-at
 528 |                                   (concat sexprw-all-whitespace-re "\\'"))))
 529 |                         (setq first-time nil)
 530 |                         (push (car result) renvs)
 531 |                         (narrow-to-region init-point (point)))
 532 |                        (t
 533 |                         (setq ok nil))))
 534 |                (setq conjuncts (cdr conjuncts)))
 535 |              (and ok (list (apply #'append (reverse renvs)))))))
 536 |         ((eq (car pattern) 'GUARD)
 537 |          (let ((result (sexprw-match (nth 1 pattern)))
 538 |                (guard (nth 2 pattern)))
 539 |            (and result
 540 |                 (let ((env (car result)))
 541 |                   (or (sexprw-check-guard-result (funcall guard env) env)
 542 |                       (sexprw-fail `(match guard env= ,env)))))))
 543 |         (t (error "Bad pattern: %S" pattern))))
 544 | 
 545 | (defun sexprw-check-guard-result (result _env)
 546 |   ;; FIXME: check result is nil or (list extension-of-env)?
 547 |   result)
 548 | 
 549 | (defun sexprw-match-var (pvar nt)
 550 |   (unless (sexprw-nt-symbolp nt)
 551 |     (error "Not defined as sexp-rewrite nt: %S" nt))
 552 |   (sexprw-skip-whitespace)
 553 |   (let* ((init-point (point))
 554 |          (nt-val (sexprw-nt-value nt))
 555 |          (nt-pattern (nth 1 nt-val))
 556 |          (nt-attrs (nth 2 nt-val)))
 557 |     (let ((result (sexprw-match nt-pattern)))
 558 |       (and result
 559 |            (sexprw-check-nonlinear-patterns (car result))
 560 |            (let ((env (sexprw-adj-env (car result) nt nt-attrs pvar)))
 561 |              (unless (assq pvar env)
 562 |                (let ((b (sexprw-range-to-block init-point nil (point))))
 563 |                  (push (cons pvar b) env)))
 564 |              (if (eq pvar '$_)
 565 |                  (list nil)
 566 |                (list env)))))))
 567 | 
 568 | (defun sexprw-adj-env (env nt attrs prefix)
 569 |   "Checks, restricts, and prefixes ENV."
 570 |   (let ((new-env nil))
 571 |     (dolist (attr attrs)
 572 |       (let ((entry (assq attr env)))
 573 |         (unless entry
 574 |           (error "Nonterminal `%S' did not bind attribute `%S'" nt attr))
 575 |         (let ((prefixed-attr
 576 |                (if (eq attr '$)
 577 |                    prefix
 578 |                  (intern (format "%s.%s" prefix attr)))))
 579 |           (push (cons prefixed-attr (cdr entry)) new-env))))
 580 |     (reverse new-env)))
 581 | 
 582 | ;; returns t on success, nil if fewer than n sexps before end
 583 | (defun sexprw-skip-forward-to-n-sexps-before-end (n)
 584 |   (cond ((zerop n)
 585 |          (goto-char (point-max)))
 586 |         (t (let ((fast (point))
 587 |                  (slow (point)))
 588 |              (setq fast (ignore-errors (scan-sexps fast n)))
 589 |              (and fast
 590 |                   (progn
 591 |                     (while fast
 592 |                       (setq fast (ignore-errors (scan-sexps fast 1)))
 593 |                       (when fast (setq slow (scan-sexps slow 1))))
 594 |                     (goto-char slow)
 595 |                     t))))))
 596 | 
 597 | (defun sexprw-match-list (inners)
 598 |   (let ((next (sexprw-grab-next-sexp t)))
 599 |     (and (or next
 600 |              (sexprw-fail `(match-list grab)))
 601 |          (member (substring (sexprw-block-pure-text next) 0 1) '("(" "[" "{"))
 602 |          ;; narrow to just after start, just before end
 603 |          (let ((result
 604 |                 (save-excursion
 605 |                   (save-restriction
 606 |                     (let ((start (sexprw-block-pure-start-position next))
 607 |                           (end (sexprw-block-end-position next)))
 608 |                       (goto-char (1+ start))
 609 |                       (narrow-to-region (1+ start) (1- end))
 610 |                       (let ((result (sexprw-match-patterns inners)))
 611 |                         (and result
 612 |                              (or (looking-at (concat sexprw-all-whitespace-re "\\'"))
 613 |                                  (sexprw-fail `(match-list end check-whitespace)))
 614 |                              result)))))))
 615 |            ;; save-excursion resets point to end of list
 616 |            result))))
 617 | 
 618 | (defun sexprw-match-patterns (inners)
 619 |   (let ((accum (list '()))) ; nil or (list alist)
 620 |     (dolist (inner inners)
 621 |       (when accum
 622 |         (let ((inner-result (sexprw-match inner)))
 623 |           (setq accum (and inner-result
 624 |                            (list (append (car inner-result) (car accum))))))))
 625 |     accum))
 626 | 
 627 | (defun sexprw-match-rep (inner after)
 628 |   ;; FIXME: add failure info
 629 |   (let ((matches nil))
 630 |     ;; matches : (listof (list match-count reversed-env-list point))
 631 |     ;; Each entry is after successfully matching inner match-count times.
 632 |     ;; Stage 1: build up matches of inner pattern
 633 |     (let ((count 0)
 634 |           (renvs nil)
 635 |           (last-point (point))
 636 |           (proceed t))
 637 |       (push (list count renvs last-point) matches)
 638 |       (while proceed
 639 |         (let ((next-result (sexprw-match inner)))
 640 |           (cond ((and next-result (> (point) last-point))
 641 |                  (setq count (1+ count))
 642 |                  (setq last-point (point))
 643 |                  (push (car next-result) renvs)
 644 |                  (push (list count renvs last-point) matches))
 645 |                 (t
 646 |                  (setq proceed nil))))))
 647 |     ;; Stage 2: search for match that satisfies after pattern
 648 |     (let ((answer nil))
 649 |       (while (and matches (not answer))
 650 |         (let* ((match0 (car matches))
 651 |                (match-renvs (nth 1 match0))
 652 |                (match-point (nth 2 match0)))
 653 |           (setq matches (cdr matches))
 654 |           (goto-char match-point)
 655 |           (let ((next-result (sexprw-match after)))
 656 |             (when next-result
 657 |               (let* ((env (sexprw-reverse-merge-alists inner match-renvs))
 658 |                      (env (append (car next-result) env)))
 659 |                 (setq answer (list env)))))))
 660 |       answer)))
 661 | 
 662 | ;; FIXME: quadratic
 663 | (defun sexprw-reverse-merge-alists (inner alists)
 664 |   ;; Not every key might appear in every alist, due to OR patterns.
 665 |   (let ((keys (delete-dups (sexprw-pattern-variables inner nil)))
 666 |         (accum nil))
 667 |     (dolist (key keys)
 668 |       (let ((values nil))
 669 |         (dolist (alist alists)
 670 |           (let ((kv (assq key alist)))
 671 |             (when kv (push (cdr kv) values))))
 672 |         ;; Don't reverse values; thus "reverse merge" alists
 673 |         (push (cons key (cons 'rep values)) accum)))
 674 |     accum))
 675 | 
 676 | (defun sexprw-pattern-variables (pattern onto)
 677 |   ;; Accept templates too
 678 |   (cond ((eq (car pattern) 'VAR)
 679 |          (when (> (length pattern) 2)
 680 |            (let* ((pvar (nth 1 pattern))
 681 |                   (nt (nth 2 pattern))
 682 |                   (nt-val (sexprw-nt-value nt)))
 683 |              (let ((attrs (nth 2 nt-val)))
 684 |                (dolist (attr attrs)
 685 |                  (unless (eq attr '$)
 686 |                    (push (intern (format "%s.%s" pvar attr)) onto))))))
 687 |          (cons (nth 1 pattern) onto))
 688 |         ((memq (car pattern) '(LIST SPLICE SQLIST OR))
 689 |          (dolist (inner (cdr pattern))
 690 |            (setq onto (sexprw-pattern-variables inner onto)))
 691 |          onto)
 692 |         ((eq (car pattern) 'pREP)
 693 |          (sexprw-pattern-variables (nth 1 pattern) 
 694 |                                    (sexprw-pattern-variables (nth 2 pattern) onto)))
 695 |         ((eq (car pattern) 'tREP)
 696 |          (sexprw-pattern-variables (nth 1 pattern) onto))
 697 |         ((memq (car pattern) '(quote SP NL SL))
 698 |          onto)
 699 |         (t (error "Bad pattern: %S" pattern))))
 700 | 
 701 | ;; ----
 702 | 
 703 | ;; A Block is (list 'block TEXT ONELINEP STARTCOL IMPUREPREFIX START END).
 704 | 
 705 | (defun sexprw-block-text (block)
 706 |   (nth 1 block))
 707 | (defun sexprw-block-onelinep (block)
 708 |   (nth 2 block))
 709 | (defun sexprw-block-start-column (block)
 710 |   (nth 3 block))
 711 | (defun sexprw-block-impure-prefix (block)
 712 |   (nth 4 block))
 713 | (defun sexprw-block-start-position (block)
 714 |   (nth 5 block))
 715 | (defun sexprw-block-end-position (block)
 716 |   (nth 6 block))
 717 | 
 718 | (defun sexprw-block-purep (block)
 719 |   (zerop (sexprw-block-impure-prefix block)))
 720 | 
 721 | (defun sexprw-block-pure-start-position (block)
 722 |   (let ((start (sexprw-block-start-position block))
 723 |         (impure-prefix (sexprw-block-impure-prefix block)))
 724 |     (unless impure-prefix
 725 |       (error "Block has unknown contents"))
 726 |     (+ start impure-prefix)))
 727 | 
 728 | (defun sexprw-block-pure-text (block)
 729 |   (let ((text (sexprw-block-text block))
 730 |         (impure-prefix (sexprw-block-impure-prefix block)))
 731 |     (cond ((null impure-prefix)
 732 |            (error "Block has unknown contents"))
 733 |           ((zerop impure-prefix)
 734 |            text)
 735 |           (t (substring text 0 impure-prefix)))))
 736 | 
 737 | (defun sexprw-block-sexpagon (block)
 738 |   (let* ((text (sexprw-block-text block))
 739 |          (start-col (sexprw-block-start-column block)))
 740 |     (sexprw-sexpagon text start-col)))
 741 | 
 742 | (defun sexprw-grab-next-sexp (require-pure)
 743 |   "Grabs next sexp and returns Block or nil.
 744 | 
 745 | A Block is (list 'block TEXT ONELINEP STARTCOL IMPUREPREFIX START END).
 746 | TEXT is a string containing the contents of the block. ONELINEP
 747 | indicates if the block consists of a single line.
 748 | 
 749 | If IMPUREPREFIX is an integer, the block represents a single sexp
 750 | preceeded by comments, and IMPUREPREFIX is the number of
 751 | characters before the start of the sexp. If IMPUREPREFIX is nil,
 752 | then TEXT may represent multiple sexps or something else
 753 | entirely.
 754 | 
 755 | If REQUIRE-PURE is non-nil, then there must be no non-whitespace
 756 | characters before the start of the sexp, or else nil is returned.
 757 | 
 758 | On success, advances point to end of sexp."
 759 |   (let ((result (sexprw-grab-next-sexp-range)))
 760 |     (and result
 761 |          (let ((nonws-point (nth 1 result))
 762 |                (start-point (nth 2 result))
 763 |                (end-point (nth 3 result)))
 764 |            (and (or (not require-pure)
 765 |                     (= nonws-point start-point))
 766 |                 (progn
 767 |                   (goto-char end-point)
 768 |                   (sexprw-range-to-block nonws-point
 769 |                                          start-point
 770 |                                          end-point)))))))
 771 | 
 772 | (defun sexprw-range-to-block (start pure-start end)
 773 |   (list 'block
 774 |         (filter-buffer-substring start end)
 775 |         (= (line-number-at-pos start)
 776 |            (line-number-at-pos end))
 777 |         (save-excursion
 778 |           (save-restriction
 779 |             (widen)
 780 |             (goto-char start)
 781 |             (- (point) (line-beginning-position))))
 782 |         (and pure-start (- pure-start start))
 783 |         start
 784 |         end))
 785 | 
 786 | (defun sexprw-grab-next-sexp-range ()
 787 |   ;; FIXME/BUG: backwards scan loses things like quote prefix, 
 788 |   ;; can lead to treating "'x" as atomic sexp (shouldn't be).
 789 |   ;; Maybe add custom comment handling to avoid backwards scan?
 790 |   "Returns (list INIT-POINT NONWS-POINT START-POINT END-POINT) or nil.
 791 | INIT-POINT is where point started. NONWS-POINT is the location of
 792 | the first non-whitespace character. START-POINT is where the sexp
 793 | starts.  END-POINT is where the sexp ends.  Does not change
 794 | point."
 795 |   (condition-case _error-info
 796 |       (save-excursion
 797 |         (let ((init-point (point)))
 798 |           (sexprw-skip-whitespace)
 799 |           (let* ((nonws-point (point))
 800 |                  (end-point (scan-sexps nonws-point 1))
 801 |                  (start-point (and end-point (scan-sexps end-point -1))))
 802 |             ;; scan-sexps signals error if EOF inside parens,
 803 |             ;; returns nil if EOF no sexp found
 804 |             (cond ((and start-point
 805 |                         (< start-point end-point))
 806 |                    (list init-point nonws-point start-point end-point))
 807 |                   (t nil)))))
 808 |     (scan-error
 809 |      ;; (message "Error is %s" error-info)
 810 |      nil)))
 811 | 
 812 | (defun sexprw-skip-whitespace ()
 813 |   (skip-chars-forward "[:space:]\n"))
 814 | 
 815 | ;; ============================================================
 816 | ;; Guard utilities
 817 | 
 818 | (defun sexprw-env-ref (env key)
 819 |   "Fetch the value associated with KEY in ENV, or nil otherwise."
 820 |   (let ((result (assq key env)))
 821 |     (and result (cdr result))))
 822 | 
 823 | (defun sexprw-guard-all-distinct (env &rest pvars)
 824 |   "Check that all of the atoms bound to the PVARS are distinct.
 825 | If there is a duplicate, or if any PVAR has a non-atom binding, return nil.
 826 | On success, return (list ENV), so suitable as the body of a guard function."
 827 |   (let ((seen (make-hash-table :test 'equal))
 828 |         (worklist nil)
 829 |         (failed nil))
 830 |     (dolist (pvar pvars)
 831 |       (setq worklist (list (sexprw-env-ref env pvar)))
 832 |       (while (and worklist (not failed))
 833 |         (let ((item (car worklist)))
 834 |           (setq worklist (cdr worklist))
 835 |           (cond ((eq (car item) 'atom)
 836 |                  (when (gethash (cadr item) seen nil)
 837 |                    (setq failed t))
 838 |                  (puthash (cadr item) seen t))
 839 |                 ((eq (car item) 'rep)
 840 |                  (setq worklist (append (cdr item) worklist)))
 841 |                 (t
 842 |                  (error "Non-atom value for pvar '%s': %S" pvar item)
 843 |                  (setq failed t))))))
 844 |     (and (or (not failed)
 845 |              (sexprw-fail `(guard all-distinct ,pvars)))
 846 |          (list env))))
 847 | 
 848 | (defun sexprw-guard-no-dot (env &rest pvars)
 849 |   "Check that none of the atoms bound to the PVARS is a dot.
 850 | On failure, return nil; on success, return (list ENV), so suitable as
 851 | guard body."
 852 |   (let ((worklist nil)
 853 |         (failed nil))
 854 |     (dolist (pvar pvars)
 855 |       (setq worklist (list (sexprw-env-ref env pvar)))
 856 |       (while (and worklist (not failed))
 857 |         (let ((item (car worklist)))
 858 |           (setq worklist (cdr worklist))
 859 |           (cond ((eq (car item) 'block)
 860 |                  (when (equal (sexprw-block-pure-text item) ".")
 861 |                    (setq failed t)))
 862 |                 ((eq (car item) 'rep)
 863 |                  (setq worklist (append (cdr item) worklist)))
 864 |                 (t
 865 |                  (error "Bad value for pvar '%s': %S" pvar item))))))
 866 |     (and (or (not failed)
 867 |              (sexprw-fail `(guard no-dot)))
 868 |          (list env))))
 869 | 
 870 | 
 871 | ;; ============================================================
 872 | ;; Templates
 873 | ;;
 874 | ;; T ::= string          ; literal text, eg "\n" inserts non-latent newline
 875 | ;;     | (quote symbol)  ; literal symbol
 876 | ;;     | (VAR symbol)    ; pattern variable
 877 | ;;     | (LIST T*)       ; parenthesized list
 878 | ;;     | (SQLIST T*)     ; bracketed list
 879 | ;;     | (SPLICE T*)     ; spliced list contents
 880 | ;;     | (SP)            ; latent space (ie, change latent newline to latent
 881 | ;;     |                 ; space)
 882 | 
 883 | ;;     | (SL)            ; latent "soft" newline: if surrounding list has any 
 884 | ;;                       ; NLs or multi-line blocks, NL, else ignore
 885 | ;;     | (NL)            ; latent newline
 886 | ;;     | (tREP T vars)   ; repetition
 887 | ;;
 888 | ;; PreOutput = (treeof PreOutputPart)
 889 | ;; PreOutputPart =
 890 | ;;   - string
 891 | ;;   - 'SP
 892 | ;;   - 'NL
 893 | ;;   - 'SL
 894 | ;;   - 'NONE
 895 | ;;   - (cons 'SEXPAGON listofstring)
 896 | ;;   - (cons 'SL=nil PreOutput)
 897 | ;;   - (cons 'SL=NL PreOutput)
 898 | ;; Interpret PreOutput left to right; *last* spacing symbol to occur wins.
 899 | ;;
 900 | ;; Output = (listof (U string 'NL (cons 'SEXPAGON listofstring)))
 901 | 
 902 | (defun sexprw-template (template env)
 903 |   "Produces (cons 'pre PreOutput) for given TEMPLATE and ENV."
 904 |   (cons 'pre (sexprw-template* (sexprw-desugar-pattern template t) env)))
 905 | 
 906 | (defvar sexprw-template*-multiline nil ;; boolean
 907 |   "True when (hard) NL or multi-line block occurs in current LIST/SQLIST.")
 908 | 
 909 | (defun sexprw-template* (template env)
 910 |   "Interprets core TEMPLATE using the pattern variables of ENV."
 911 |   ;; (message "** template = %S" template)
 912 |   (cond ((stringp template)
 913 |          template)
 914 |         ((not (consp template))
 915 |          (error "Bad template: %S" template))
 916 |         ((eq (car template) 'quote)
 917 |          (list (symbol-name (cadr template))
 918 |                'SP))
 919 |         ((eq (car template) 'VAR)
 920 |          (sexprw-template-var (cadr template) env))
 921 |         ((memq (car template) '(LIST SQLIST))
 922 |          (let ((open (if (eq (car template) 'LIST) "(" "["))
 923 |                (close (if (eq (car template) 'LIST) ")" "]"))
 924 |                (multiline nil))
 925 |            (let ((contents
 926 |                   (let ((sexprw-template*-multiline nil)) ;; fluid-let
 927 |                     (prog1 (sexprw-template-list-contents (cdr template) env)
 928 |                       (setq multiline sexprw-template*-multiline)))))
 929 |              (when multiline (setq sexprw-template*-multiline t))
 930 |              (list open
 931 |                    (cons (if multiline 'SL=NL 'SL=nil) contents)
 932 |                    'NONE
 933 |                    close
 934 |                    'SP))))
 935 |         ((eq (car template) 'SPLICE)
 936 |          (sexprw-template-list-contents (cdr template) env))
 937 |         ((memq (car template) '(SP NL SL NONE))
 938 |          (car template))
 939 |         ((eq (car template) 'tREP)
 940 |          (sexprw-template-rep template env))))
 941 | 
 942 | (defun sexprw-template-rep (template env)
 943 |   ;; (message "env for rep = %S" env)
 944 |   (let* ((inner (nth 1 template))
 945 |          (vars (or (nth 2 template)
 946 |                    ;; Take *all* depth>0 pvars in env that occur in template
 947 |                    ;; (beware duplicate keys in alist)
 948 |                    (let* ((env-keys (sexprw-pattern-variables template '()))
 949 |                           ;; FIXME: Ack! quadratic, mutates, etc
 950 |                           (env-keys (delete-dups env-keys))
 951 |                           (raccum '()))
 952 |                      (dolist (key env-keys)
 953 |                        (when (eq (car (cdr (assq key env))) 'rep)
 954 |                          (setq raccum (cons key raccum))))
 955 |                      (reverse raccum))))
 956 |          (vals (mapcar (lambda (pvar)
 957 |                          (let ((entry (assq pvar env)))
 958 |                            (unless entry
 959 |                              (error "No entry for pvar '%s' in: %S" pvar env))
 960 |                            (let ((value (cdr entry)))
 961 |                              (unless (and (consp value) (eq (car value) 'rep))
 962 |                                (error "Value for pvar '%s' is not list (depth error): %S"
 963 |                                       pvar entry))
 964 |                              (cdr value))))
 965 |                        vars)))
 966 |     (unless vars (error "No repetition vars for tREP: %S" template))
 967 |     (let* ((lengths (mapcar #'length vals))
 968 |            (length1 (car lengths)))
 969 |       (dolist (l lengths)
 970 |         (unless (= l length1)
 971 |           (signal 'template-error 'ellipsis-count-mismatch)))
 972 |       (let ((raccum '()))
 973 |         (dotimes (_i length1)
 974 |           (let* ((extenv+vals (sexprw-split/extend-env vars vals env))
 975 |                  (extenv (car extenv+vals)))
 976 |             (setq vals (cdr extenv+vals))
 977 |             (setq raccum 
 978 |                   (cons (sexprw-template* inner extenv)
 979 |                         raccum))))
 980 |         (reverse raccum)))))
 981 | 
 982 | (defun sexprw-split/extend-env (vars vals env)
 983 |   (let* ((val1s (mapcar #'car vals))
 984 |          (rests (mapcar #'cdr vals)))
 985 |     (while vars
 986 |       (setq env (cons (cons (car vars) (car val1s)) env))
 987 |       (setq vars (cdr vars))
 988 |       (setq val1s (cdr val1s)))
 989 |     (cons env rests)))
 990 | 
 991 | (defun sexprw-template-var (pvar env)
 992 |   (let ((entry (assq pvar env)))
 993 |     (unless entry
 994 |       (error "No entry for pvar '%s'" pvar))
 995 |     (let ((value (cdr entry)))
 996 |       (cond ((and (consp value) (eq (car value) 'block))
 997 |              (let ((text (sexprw-block-text value))
 998 |                    (lines (sexprw-block-sexpagon value))
 999 |                    (space (if (sexprw-block-onelinep value) 'SP 'NL)))
1000 |                (unless (sexprw-block-onelinep value)
1001 |                  (setq sexprw-template*-multiline t))
1002 |                (cond ((zerop (length text))
1003 |                       ;; no space after empty block
1004 |                       nil)
1005 |                      (lines
1006 |                       (list (cons 'SEXPAGON lines) space))
1007 |                      (t
1008 |                       (list text space)))))
1009 |             ((and (consp value) (eq (car value) 'pre))
1010 |              ;; 'pre entry should already include trailing space
1011 |              (cdr value))
1012 |             ((and (consp value) (eq (car value) 'rep))
1013 |              (error "Depth error for pvar '%s'; value is: %S" pvar value))
1014 |             (t (error "Bad pvar value for pvar '%s': %s" pvar value))))))
1015 | 
1016 | (defun sexprw-template-list-contents (inners env)
1017 |   ;; We don't add inter-element spacing here; 
1018 |   ;; each element should add its own trailing spacing.
1019 |   (let ((accum (list '()))) ; nil or (list PreOutput)
1020 |     (dolist (inner inners)
1021 |       (setq accum (cons accum (sexprw-template* inner env))))
1022 |     accum))
1023 | 
1024 | ;; sexprw-output*-SL : (U nil 'NL), fluid
1025 | (defvar sexprw-output*-SL nil)
1026 | 
1027 | (defun sexprw-output (pre)
1028 |   (let* ((result (sexprw-output* pre nil 'NONE))
1029 |          (raccum (car result))
1030 |          (_latent (cdr result)))
1031 |     (let ((sexprw-output*-SL nil)) ;; fluid-let
1032 |       (reverse raccum))))
1033 | 
1034 | (defun sexprw-output* (pre raccum latent)
1035 |   (cond ((and (consp pre) (eq (car pre) 'SEXPAGON))
1036 |          (let* ((raccum (cons (sexprw-output*-spacing latent) raccum))
1037 |                 (raccum (cons pre raccum)))
1038 |            (cons raccum 'NONE)))
1039 |         ((and (consp pre) (eq (car pre) 'SL=nil))
1040 |          (let ((sexprw-output*-SL nil)) ;; fluid-let
1041 |            (sexprw-output* (cdr pre) raccum latent)))
1042 |         ((and (consp pre) (eq (car pre) 'SL=NL))
1043 |          (let ((sexprw-output*-SL 'NL)) ;; fluid-let
1044 |            (sexprw-output* (cdr pre) raccum latent)))
1045 |         ((consp pre)
1046 |          (let ((result (sexprw-output* (car pre) raccum latent)))
1047 |            (sexprw-output* (cdr pre) (car result) (cdr result))))
1048 |         ((stringp pre)
1049 |          (let* ((raccum (cons (sexprw-output*-spacing latent) raccum))
1050 |                 (raccum (cons pre raccum)))
1051 |            (cons raccum 'NONE)))
1052 |         ((null pre)
1053 |          (cons raccum latent))
1054 |         ((symbolp pre)
1055 |          (cons raccum
1056 |                (if (eq pre 'SL) (or sexprw-output*-SL latent) pre)))
1057 |         (t
1058 |          (error "Bad pre-output: %S" pre))))
1059 | 
1060 | (defun sexprw-output*-spacing (spacing)
1061 |   (cond ((eq spacing 'NL) 'NL)
1062 |         ((eq spacing 'SP) " ")
1063 |         ((eq spacing 'NONE) "")
1064 |         (t (error "Bad spacing: %S" spacing))))
1065 | 
1066 | (defun sexprw-emit (output)
1067 |   (while output
1068 |     (let ((fragment (car output)))
1069 |       (setq output (cdr output))
1070 |       (cond ((eq fragment 'NL)
1071 |              (newline-and-indent))
1072 |             ((stringp fragment)
1073 |              (insert fragment))
1074 |             ((and (consp fragment) (eq (car fragment) 'SEXPAGON))
1075 |              (sexprw-emit-sexpagon (cdr fragment)))
1076 |             (t (error "Bad output: %S" (car output)))))))
1077 | 
1078 | ;; ============================================================
1079 | ;; Convert to square brackets
1080 | 
1081 | (defun sexprw-squarify (&optional times)
1082 |   "Turn round parens into square brackets."
1083 |   (interactive "P")
1084 |   (let ((times (cond ((numberp times) times)
1085 |                      ((consp times) (car times))
1086 |                      ((null times) nil))))
1087 |     (save-excursion
1088 |       (sexprw-rebracket-repeat times "(" "[" "]" "parenthesis"))
1089 |     nil))
1090 | 
1091 | (defun sexprw-roundify (&optional times)
1092 |   "Turn square brackets into round parens."
1093 |   (interactive "P")
1094 |   (let ((times (cond ((numberp times) times)
1095 |                      ((consp times) (car times))
1096 |                      ((null times) nil))))
1097 |     (save-excursion
1098 |       (sexprw-rebracket-repeat times "[" "(" ")" "square bracket"))
1099 |     nil))
1100 | 
1101 | (defun sexprw-open-bracket-re (from)
1102 |   ;; (concat "[[:space:]]*" (regexp-quote from))
1103 |   ;; (concat "\\s-*" (regexp-quote from))  ; doesn't get newlines
1104 |   (concat sexprw-all-whitespace-re (regexp-quote from)))
1105 | 
1106 | (defun sexprw-rebracket-once (from to-open to-close bracket-name)
1107 |   (cond ((looking-at (sexprw-open-bracket-re from))
1108 |          (let (end)
1109 |            (forward-list 1)
1110 |            (setq end (1- (point)))
1111 |            (backward-list 1)
1112 |            (delete-char 1)
1113 |            (insert to-open)
1114 |            (goto-char end)
1115 |            (delete-char 1)
1116 |            (insert to-close)
1117 |            ;; (goto-char (1+ (point)))
1118 |            ))
1119 |         (t
1120 |          (message "Not at open %s" bracket-name))))
1121 | 
1122 | (defun sexprw-rebracket-repeat (times from to-open to-close bracket-name)
1123 |   (let ((start-re (sexprw-open-bracket-re from)))
1124 |     (while (and (looking-at start-re)
1125 |                 (or (not times) (> times 0)))
1126 |       (when times (setq times (1- times)))
1127 |       (sexprw-rebracket-once from to-open to-close bracket-name))))
1128 | 
1129 | ;; ============================================================
1130 | ;; Search with patterns
1131 | 
1132 | (defun sexprw-search-pattern (pattern)
1133 |   "Search forward for sexp matching PATTERN."
1134 |   (interactive
1135 |    (list (read-from-minibuffer "Search pattern: " nil nil t
1136 |                                'sexprw-pattern-history)))
1137 |   (let ((sexprw-current-operation 'search)) ;; fluid-let
1138 |     (setq sexprw-failure-info nil)
1139 |     (let ((init-point (point))
1140 |           (result (sexprw-search-pattern/ast (sexprw-desugar-pattern pattern nil))))
1141 |       (cond (result
1142 |              (push-mark init-point)
1143 |              (message "Pattern found; mark saved where search started"))
1144 |             (t
1145 |              (goto-char init-point)
1146 |              (message "Pattern not found"))))))
1147 | 
1148 | (defun sexprw-search-pattern/ast (pattern)
1149 |   ;; Note: moves point
1150 |   ;; (message "search pattern = %S" pattern)
1151 |   (let ((success nil)
1152 |         (continue t))
1153 |     (while continue
1154 |       (setq continue nil)
1155 |       (sexprw-skip-whitespace)
1156 |       (let ((result (save-excursion (sexprw-match pattern))))
1157 |         (cond (result
1158 |                (setq success result))
1159 |               (t
1160 |                (setq continue (sexprw-move-forward))))))
1161 |     success))
1162 | 
1163 | (defun sexprw-move-forward ()
1164 |   "Moves point forward along sexp boundaries.
1165 | Can move forward by skipping whitespace, moving to start of next
1166 | sexp, moving to end of next sexp, moving into list, or moving out
1167 | of list."
1168 |   (let* ((init-point (point))
1169 |          (next-sexp-end (ignore-errors (scan-sexps init-point 1)))
1170 |          (next-sexp-start (and next-sexp-end
1171 |                                (ignore-errors (scan-sexps next-sexp-end -1))))
1172 |          (next-list-start (ignore-errors (scan-lists init-point 1 -1))))
1173 |     ;; (message "next-sexp-end = %s, next-list-start = %s"
1174 |     ;;          next-sexp-end next-list-start)
1175 |     (cond ((and next-sexp-start (> next-sexp-start init-point))
1176 |            ;; (message "Going to start of next sexp")
1177 |            (goto-char next-sexp-start)
1178 |            t)
1179 |           ((not next-sexp-end)
1180 |            ;; try going up
1181 |            ;; (message "Going up")
1182 |            (progn (ignore-errors (up-list 1)) (> (point) init-point)))
1183 |           ((or (not next-list-start)
1184 |                (> next-list-start next-sexp-end))
1185 |            ;; (message "Going forward")
1186 |            ;; next sexp is not a list
1187 |            (goto-char next-sexp-end)
1188 |            t)
1189 |           (t
1190 |            ;; (message "Going down")
1191 |            (progn (ignore-errors (down-list 1)) (> (point) init-point))))))
1192 | 
1193 | ;; ============================================================
1194 | ;; Search and Rewrite
1195 | 
1196 | (defun sexprw-search-rewrite (pattern template)
1197 |   "Search forward for sexp matching PATTERN."
1198 |   (interactive
1199 |    (list (read-from-minibuffer "Search pattern: " nil nil t
1200 |                                'sexprw-pattern-history)
1201 |          (read-from-minibuffer "Rewrite template: " nil nil t
1202 |                                'sexprw-template-history)))
1203 |   (let ((sexprw-current-operation 'search)) ;; fluid-let
1204 |     (setq sexprw-failure-info nil)
1205 |     (let ((init-point (point))
1206 |           (result (sexprw-search-pattern/ast (sexprw-desugar-pattern pattern nil))))
1207 |       (cond (result
1208 |              (push-mark init-point)
1209 |              (message "Pattern found; mark saved where search started")
1210 |              (sexprw-rewrite pattern template))
1211 |             (t
1212 |              (goto-char init-point)
1213 |              (message "Pattern not found"))))))
1214 | 
1215 | ;; ============================================================
1216 | ;; Sexpagon functions
1217 | 
1218 | ;; A "sexpagon" is the shape of a well-formatted sexp:
1219 | 
1220 | ;;     (----------+
1221 | ;;     |          |
1222 | ;;     |      +---+
1223 | ;;     +------)
1224 | 
1225 | ;; There must be no non-whitespace characters to the left of the open
1226 | ;; paren's column from the second line to the last. Well-formatted
1227 | ;; Lisp/Scheme/Racket code is nearly always sexpagonal, with the
1228 | ;; occasional exception of multi-line string literals.
1229 | 
1230 | (defun sexprw-sexpagon (text start-col)
1231 |   (let* ((lines (split-string text "[\n]" nil))
1232 |          (ok t)
1233 |          (rtext nil))
1234 |     ;; First line already has indentation removed
1235 |     (push (car lines) rtext)
1236 |     (setq lines (cdr lines))
1237 |     ;; Process successive lines
1238 |     (while (and ok lines)
1239 |       (let* ((line (car lines))
1240 |              (line-end (length line))
1241 |              (col (min start-col line-end)))
1242 |         (if (string-match "^ *$" (substring line 0 col))
1243 |             (push (substring line col) rtext)
1244 |           (setq ok nil)))
1245 |       (setq lines (cdr lines)))
1246 |     (and ok (reverse rtext))))
1247 | 
1248 | (defun sexprw-kill-next-sexpagon-sexp ()
1249 |   "Kills the sexp at point, preserving relative indentation.
1250 | The sexp must be a sexpagon. Whitespace is removed from lines
1251 | after the first so the sexp will be properly indented when
1252 | `yank'ed at column 0 or yanked via `sexprw-yank-sexpagon'."
1253 |   (interactive)
1254 |   (let* ((init-point (point))
1255 |          (next (sexprw-grab-next-sexp-range)))
1256 |     (unless next
1257 |       (error "No sexp at point"))
1258 |     (let* ((start (nth 1 next))
1259 |            (start-col (save-excursion
1260 |                         (save-restriction
1261 |                           (widen)
1262 |                           (goto-char start)
1263 |                           (- start (line-beginning-position)))))
1264 |            (end (nth 3 next))
1265 |            (lines (sexprw-sexpagon (filter-buffer-substring start end) start-col)))
1266 |       (unless lines
1267 |         (error "Non-sexpagonal sexp at point"))
1268 |       (let ((text (mapconcat 'identity lines "\n")))
1269 |         (delete-and-extract-region init-point end)
1270 |         (kill-new text)))))
1271 | 
1272 | (defun sexprw-kill-sexpagon-region (start end)
1273 |   "Kills from START to END, preserving relative indentation.
1274 | The region must be a sexpagon. Whitespace is removed from lines
1275 | after the first so the sexp will be properly indented when
1276 | `yank'ed at column 0 or yanked via `sexprw-yank-sexpagon'."
1277 |   (interactive "r")
1278 |   (let ((text (filter-buffer-substring start end))
1279 |         (start-col (save-excursion
1280 |                      (save-restriction
1281 |                        (widen)
1282 |                        (goto-char start)
1283 |                        (- start (line-beginning-position))))))
1284 |     (let ((lines (sexprw-sexpagon text start-col)))
1285 |       (unless lines
1286 |         (error "Non-sexpagonal region"))
1287 |       (let ((text (mapconcat 'identity lines "\n")))
1288 |         (delete-and-extract-region start end)
1289 |         (kill-new text)))))
1290 | 
1291 | (defun sexprw-yank-sexpagon ()
1292 |   "Yanks text, preserving relative indentation of multi-line text.
1293 | Whitespace is added to lines after the first so each line starts
1294 | at the same column as the first line."
1295 |   (interactive)
1296 |   (let ((text (current-kill 0)))
1297 |     (unless text
1298 |       (error "No text in kill ring"))
1299 |     (sexprw-emit-sexpagon (split-string text "[\n]" nil))))
1300 | 
1301 | (defun sexprw-emit-sexpagon (lines)
1302 |   (let ((col (save-restriction
1303 |                (widen)
1304 |                (- (point) (line-beginning-position)))))
1305 |     (when lines
1306 |       (insert (car lines))
1307 |       (setq lines (cdr lines)))
1308 |     (while lines
1309 |       (insert "\n")
1310 |       (unless (zerop (length (car lines)))
1311 |         (indent-to col))
1312 |       (insert (car lines))
1313 |       (setq lines (cdr lines)))))
1314 | 
1315 | ;; ============================================================
1316 | 
1317 | ;; sexp-rewrite nonterminal names have property 'sexprw-nt
1318 | ;; with value (list 'nt P attrs docstring), where attrs is list of symbol
1319 | 
1320 | (defmacro define-sexprw-nt (name &rest clauses)
1321 |   ;; FIXME: Don't make such definitions global since different languages will
1322 |   ;; likely want different non-terminals.
1323 |   "Define NAME as a sexp-rewrite nonterminal specified by the CLAUSES."
1324 |   `(progn (put ',name 'sexprw-nt (sexprw-parse-nt-def ',clauses)) ',name))
1325 | 
1326 | (defun sexprw-parse-nt-def (clauses)
1327 |   (let ((docstring nil)
1328 |         (attrs nil))
1329 |     (when (and (consp clauses)
1330 |                (stringp (car clauses)))
1331 |       (setq docstring (car clauses))
1332 |       (setq clauses (cdr clauses)))
1333 |     (when (and (>= (length clauses) 2)
1334 |                (eq (car clauses) ':attributes))
1335 |       (setq attrs (cadr clauses))
1336 |       (dolist (attr attrs)
1337 |         (unless (symbolp attr)
1338 |           (error "Expected symbol for attribute: %S" attr)))
1339 |       (setq clauses (cddr clauses)))
1340 |     (let* ((patterns (mapcar #'sexprw-parse-clause clauses))
1341 |            (pattern (if (= 1 (length patterns))
1342 |                         (car patterns)
1343 |                       (cons 'OR patterns))))
1344 |       (list 'nt pattern attrs docstring))))
1345 | 
1346 | (defun sexprw-parse-clause (clause)
1347 |   (let ((parts clause)
1348 |         (pattern nil))
1349 |     (unless (and (consp parts)
1350 |                  (eq (car parts) 'pattern)
1351 |                  (>= (length parts) 2))
1352 |       (error "Bad sexp-rewrite nonterminal clause: %S" clause))
1353 |     (let ((pattern+parts (sexprw-parse-pattern+clauses (cdr parts) clause)))
1354 |       (setq pattern (car pattern+parts))
1355 |       (setq parts (cdr pattern+parts))
1356 |       (when parts
1357 |         (error "Bad clause options: %S" clause))
1358 |       pattern)))
1359 | 
1360 | (defun sexprw-parse-pattern+clauses (parts whole)
1361 |   ;; Returns (cons pattern leftover-parts)
1362 |   (let ((pattern nil))
1363 |     (unless (consp parts)
1364 |       (error "Missing pattern: %S" whole))
1365 |     (setq pattern (sexprw-desugar-pattern (car parts) nil))
1366 |     (setq parts (cdr parts))
1367 |     (while (and parts (keywordp (car parts)))
1368 |       (cond ((eq (car parts) ':guard)
1369 |              (unless (>= (length parts) 2)
1370 |                (error "Missing expression for :guard option: %S" whole))
1371 |              (setq pattern `(GUARD ,pattern ,(nth 1 parts)))
1372 |              (setq parts (nthcdr 2 parts)))
1373 |             ((eq (car parts) ':with)
1374 |              ;; FIXME: support (pvar ...), etc
1375 |              (unless (>= (length parts) 3)
1376 |                (error "Missing variable or template for :with option: %S" whole))
1377 |              (let* ((pvar (nth 1 parts))
1378 |                     (template (nth 2 parts))
1379 |                     (with-guard
1380 |                      `(lambda (env)
1381 |                         (let ((pre (sexprw-template ',template env)))
1382 |                           (list (cons (cons ',pvar pre) env))))))
1383 |                (setq pattern `(GUARD ,pattern ,with-guard))
1384 |                (setq parts (nthcdr 3 parts))))
1385 |             (t
1386 |              (error "Bad clause option keyword: %S" (car parts)))))
1387 |     (cons pattern parts)))
1388 | 
1389 | (defun sexprw-nt-symbolp (sym)
1390 |   (and (get sym 'sexprw-nt) t))
1391 | 
1392 | (defun sexprw-nt-value (sym)
1393 |   (or (and (symbolp sym) (get sym 'sexprw-nt))
1394 |       (error "Not a sexp-rewrite nt name: %S" sym)))
1395 | 
1396 | ;; ============================================================
1397 | 
1398 | ;; A sexp-rewrite tactic name is an nt that that defines $out and also
1399 | ;; has the property 'sexprw-tactic.
1400 | 
1401 | (defmacro define-sexprw-tactic (name &rest parts)
1402 |   ;; FIXME: Don't make those rules global since different languages will
1403 |   ;; want different rules.
1404 |   "Define NAME as a sexprw-rewrite tactic."
1405 |   (unless (and name (symbolp name))
1406 |     (error "define-sexprw-tactic: expected symbol for NAME, got: %S" name))
1407 |   `(progn (put ',name 'sexprw-nt (sexprw-parse-tactic-defn ',name ',parts))
1408 |           (put ',name 'sexprw-tactic t)
1409 |           ',name))
1410 | 
1411 | (defun sexprw-tactic-symbolp (sym)
1412 |   (and (get sym 'sexprw-tactic) t))
1413 | 
1414 | (defun sexprw-parse-tactic-defn (name parts)
1415 |   (let* ((whole (cons 'define-sexprw-tactic (cons name parts)))
1416 |          (pattern+parts (sexprw-parse-pattern+clauses parts whole))
1417 |          (pattern (car pattern+parts))
1418 |          (template nil))
1419 |     (setq parts (cdr pattern+parts))
1420 |     (unless parts
1421 |       (error "Missing template: %S" whole))
1422 |     (setq template (car parts))
1423 |     (setq parts (cdr parts))
1424 |     (when parts
1425 |       (error "Extra terms after template: %S" whole))
1426 |     `(nt (GUARD ,pattern
1427 |                 (lambda (env)
1428 |                   (let ((pre (sexprw-template ',template env)))
1429 |                     (list (cons (cons '$out pre) env)))))
1430 |          ($out) nil)))
1431 | 
1432 | (defun sexprw-read-tactic-from-minibuffer ()
1433 |   (intern
1434 |    (completing-read "Tactic: "
1435 |                     obarray
1436 |                     'sexprw-tactic-symbolp
1437 |                     t
1438 |                     nil
1439 |                     'sexprw-tactic-history)))
1440 | 
1441 | ;; ============================================================
1442 | 
1443 | ;; Built-in sexprw nonterminals
1444 | 
1445 | ;; Sneaky tricks: 
1446 | ;;  - (!SPLICE) is no-op pattern
1447 | ;   - guard can use and move point (discouraged in user nts, though!)
1448 | 
1449 | (define-sexprw-nt pure-sexp
1450 |   :attributes ($)
1451 |   (pattern (!SPLICE)
1452 |            :guard (lambda (env)
1453 |                     (let ((next (sexprw-grab-next-sexp t)))
1454 |                       (and (or next
1455 |                                (sexprw-fail `(match var pure-sexp grab)))
1456 |                            (list (list (cons '$ next))))))))
1457 | 
1458 | (define-sexprw-nt sexp
1459 |   :attributes ($)
1460 |   (pattern (!SPLICE)
1461 |            :guard (lambda (env)
1462 |                     (let ((next (sexprw-grab-next-sexp nil)))
1463 |                       (and (or next
1464 |                                (sexprw-fail `(match var sexp grab)))
1465 |                            (list (list (cons '$ next))))))))
1466 | 
1467 | (define-sexprw-nt id
1468 |   :attributes ($)
1469 |   (pattern $x:pure-sexp
1470 |            :guard (lambda (env)
1471 |                     (let* ((x (sexprw-env-ref env '$x))
1472 |                            (pure-text (sexprw-block-pure-text x)))
1473 |                       ;; (message "x = %S" x)
1474 |                       ;; (message "pure-text = %S" pure-text)
1475 |                       (and (or (string-match sexprw-pure-atom-re pure-text)
1476 |                                (sexprw-fail `(match var sym atom)))
1477 |                            (list (list (cons '$ x))))))))
1478 | 
1479 | (define-sexprw-nt rest
1480 |   "Rest of matchable text"
1481 |   :attributes ($)
1482 |   (pattern (!SPLICE)
1483 |            :guard (lambda (env)
1484 |                     (sexprw-skip-whitespace) ;; FIXME: redundant?
1485 |                     (let ((init-point (point)))
1486 |                       (goto-char (point-max))
1487 |                       (let ((b (sexprw-range-to-block init-point nil (point))))
1488 |                         (list (list (cons '$ b))))))))
1489 | 
1490 | (define-sexprw-nt rest1
1491 |   "Rest but for one sexp"
1492 |   :attributes ($)
1493 |   (pattern (!SPLICE)
1494 |            :guard (lambda (env)
1495 |                     (sexprw-skip-whitespace) ;; FIXME: redundant?
1496 |                     (let ((init-point (point)))
1497 |                       (and (sexprw-skip-forward-to-n-sexps-before-end 1)
1498 |                            (let ((b (sexprw-range-to-block init-point nil (point))))
1499 |                              (list (list (cons '$ b)))))))))
1500 | 
1501 | ;; ============================================================
1502 | 
1503 | (defun sexprw-collapse-space/move-sexps (count)
1504 |   "Collapse space after point, moving COUNT (or all) following sexps.
1505 | If COUNT is nil, moves all following sexps."
1506 |   (interactive "P") 
1507 |   (when (consp count) (setq count (car count)))
1508 |   (unless (integerp count) (setq count nil))
1509 |   (save-excursion
1510 |     (let ((init-point (point)))
1511 |       (sexprw-skip-whitespace)
1512 |       (let ((start (point))
1513 |             (start-col (save-restriction
1514 |                          (widen)
1515 |                          (- (point) (line-beginning-position)))))
1516 |         (cond (count (ignore-errors (dotimes (_i count) (forward-sexp))))
1517 |               (t (up-list)))
1518 |         (end-of-line) ;; get trailing close-parens too, if on same line
1519 |         (let* ((end (point))
1520 |                (text (filter-buffer-substring start end))
1521 |                (lines (sexprw-sexpagon text start-col)))
1522 |           (unless lines
1523 |             (error "Non-sexpagonal region"))
1524 |           (delete-region start end)
1525 |           (goto-char init-point) ;; FIXME: redundant?
1526 |           (sexprw-emit-sexpagon lines))))))
1527 | 
1528 | ;; ============================================================
1529 | 
1530 | (defun sexprw-indent-rigidly (count)
1531 |   "Set the active region and call `sexprw-indent-region-rigidly'.
1532 | The region is set according to the following rules:
1533 | 
1534 | - If a region is already active, that region is used.
1535 | - If the prefix argument is a positive integer COUNT, then the
1536 |   region consists of the next COUNT S-expressions.
1537 | - Otherwise, the region extends to the end of the enclosing
1538 |   S-expression (if there is one) or to the end of the buffer."
1539 |   (interactive "P")
1540 |   (when (consp count) (setq count (car count)))
1541 |   (unless (integerp count) (setq count nil))
1542 |   (cond ((region-active-p)
1543 |          (sexprw-indent-region-rigidly))
1544 |         ((and (integerp count) (> count 0))
1545 |          (sexprw-skip-whitespace)
1546 |          (let ((end (save-excursion
1547 |                       (ignore-errors (dotimes (_i count) (forward-sexp)))
1548 |                       (point))))
1549 |            (push-mark end t t)
1550 |            (sexprw-indent-region-rigidly)))
1551 |         (t
1552 |          (sexprw-skip-whitespace)
1553 |          (let ((end (save-excursion
1554 |                       (or (ignore-errors (up-list) (point))
1555 |                           (point-max)))))
1556 |            (push-mark end t t)
1557 |            (sexprw-indent-region-rigidly)))))
1558 | 
1559 | (defvar sexprw-indent-rigidly-map
1560 |   (let ((map (make-sparse-keymap)))
1561 |     (define-key map [left]   'sexprw-indent-rigidly-left)
1562 |     (define-key map [right]  'sexprw-indent-rigidly-right)
1563 |     (define-key map [up]     'sexprw-indent-rigidly-up)
1564 |     (define-key map [down]   'sexprw-indent-rigidly-down)
1565 |     (define-key map [return] 'sexprw-indent-rigidly-newline)
1566 |     (define-key map [tab]    'sexprw-indent-rigidly-indent)
1567 |     map)
1568 |   "Transient keymap for adjusting indentation interactively.
1569 | It is activated by calling `sexprw-indent-region-rigidly' interactively.")
1570 | 
1571 | (defun sexprw-indent-region-rigidly ()
1572 |   "Like `indent-rigidly' but also moves the selected segment of
1573 | the first line and can move the region vertically as well as
1574 | horizontally."
1575 |   (interactive)
1576 |   (message
1577 |    (substitute-command-keys
1578 |     "Move region with \\<sexprw-indent-rigidly-map>\\[sexprw-indent-rigidly-left], \\[sexprw-indent-rigidly-right], \\[sexprw-indent-rigidly-up], \\[sexprw-indent-rigidly-down], \\[sexprw-indent-rigidly-newline], or \\[sexprw-indent-rigidly-indent]."))
1579 |   ;; FIXME: `undo' gives "undo in region" warning, bad behavior! I tried passing
1580 |   ;; `deactivate-mark' as the on-exit callback, but it didn't seem to help.
1581 |   (set-transient-map sexprw-indent-rigidly-map t))
1582 | 
1583 | (defun sexprw-indent-rigidly--pop-undo ()
1584 |   (and (memq last-command '(sexprw-indent-rigidly-left
1585 |                             sexprw-indent-rigidly-right
1586 |                             sexprw-indent-rigidly-up
1587 |                             sexprw-indent-rigidly-down
1588 |                             sexprw-indent-rigidly-newline
1589 |                             sexprw-indent-rigidly-indent))
1590 |        (consp buffer-undo-list)
1591 |        (eq (car buffer-undo-list) nil)
1592 |        (pop buffer-undo-list)))
1593 | 
1594 | (defun sexprw--region-excursion (proc)
1595 |   "Like save-excursion, but keeps the region over the same bits
1596 | of text. IIUC, save-excursion uses markers with the wrong
1597 | insertion mode, so inserted whitespace would become part of the
1598 | region. That can be fixed with insert-before-markers, but that
1599 | won't work for newline-and-indent, etc.  Also does additional
1600 | transient mode stuff (undos, keep mark active)."
1601 |   (when (region-active-p)
1602 |     (sexprw-indent-rigidly--pop-undo)
1603 |     (let ((am (copy-marker (region-beginning) t))
1604 |           (bm (copy-marker (region-end))))
1605 |       (save-excursion
1606 |         (goto-char am)
1607 |         (funcall proc am bm))
1608 |       (goto-char am)
1609 |       (set-mark bm)
1610 |       (move-marker am nil)
1611 |       (move-marker bm nil)))
1612 |   ;; Keep the active region in transient mode.
1613 |   (when (eq (cadr overriding-terminal-local-map) sexprw-indent-rigidly-map)
1614 |     (setq deactivate-mark nil)))
1615 | 
1616 | (defun sexprw-indent-rigidly-right ()
1617 |   "Move the active region right by one space."
1618 |   (interactive)
1619 |   (sexprw--region-excursion
1620 |    (lambda (beg end)
1621 |      (insert " ")
1622 |      (forward-line 1)
1623 |      (when (< (point) end)
1624 |        (indent-rigidly (point) end 1)))))
1625 | 
1626 | (defun sexprw-indent-rigidly-left ()
1627 |   "Move the active region left by one space. If there is no
1628 | horizontal whitespace immediately before the region, there is no
1629 | effect."
1630 |   ;; FIXME: preserve indentation
1631 |   ;; FIXME: use current-column, indent-to to preserve tabs?
1632 |   (interactive)
1633 |   (sexprw--region-excursion
1634 |    (lambda (beg end)
1635 |      (when (looking-back " " (1- beg))
1636 |        (delete-region (1- beg) beg)
1637 |        (goto-char beg)
1638 |        (forward-line 1)
1639 |        (when (< (point) end)
1640 |          (indent-rigidly (point) end -1))))))
1641 | 
1642 | (defun sexprw-indent-rigidly-down ()
1643 |   "Move the active region down by one line on the same column."
1644 |   (interactive)
1645 |   (sexprw--region-excursion
1646 |    (lambda (beg end)
1647 |      (let ((col (current-column)))
1648 |        (delete-horizontal-space t)
1649 |        (newline)
1650 |        (indent-to col)))))
1651 | 
1652 | (defun sexprw-indent-rigidly-up ()
1653 |   "Move the active region up by one line. If there are
1654 | non-whitespace characters on the line where the region starts,
1655 | this command has no effect. Otherwise, the region is moved up on
1656 | the same column or on the first column after all non-whitespace
1657 | characters."
1658 |   (interactive)
1659 |   (sexprw--region-excursion
1660 |    (lambda (beg end)
1661 |      (let* ((col (current-column))
1662 |             (up (save-excursion
1663 |                   (forward-line -1)
1664 |                   (move-to-column col t)
1665 |                   (point)))
1666 |             (line-start (line-beginning-position)))
1667 |        (skip-chars-backward "[:space:]\n" up)
1668 |        (let ((pos (point))
1669 |              (col2 (current-column)))
1670 |          (when (< pos line-start)
1671 |            (delete-region pos beg)
1672 |            (forward-line 1)
1673 |            (when (< (point) end)
1674 |              (indent-rigidly (point) end (- col2 col)))))))))
1675 | 
1676 | (defun sexprw-indent-rigidly-indent ()
1677 |   "Move the active region by indenting (using
1678 | `indent-according-to-mode'), and preserve the relative
1679 | indentation of the subsequent lines."
1680 |   (interactive)
1681 |   (sexprw--region-excursion
1682 |    (lambda (beg end)
1683 |      (let ((col (current-column)))
1684 |        (when (looking-back "^[\t ]*")
1685 |          (indent-according-to-mode)
1686 |          (let ((col2 (current-column)))
1687 |            (forward-line 1)
1688 |            (when (< (point) end)
1689 |              (indent-rigidly (point) end (- col2 col)))))))))
1690 | 
1691 | (defun sexprw-indent-rigidly-newline ()
1692 |   "Move the active region down one line and indent the first
1693 | line (using `newline-and-indent'), and preserve the relative
1694 | indentation of the subsequent lines."
1695 |   (interactive)
1696 |   (sexprw--region-excursion
1697 |    (lambda (beg end)
1698 |      (let ((col1 (current-column)))
1699 |        (newline-and-indent)
1700 |        (let ((col2 (current-column)))
1701 |          (forward-line 1)
1702 |          (when (< (point) end)
1703 |            (indent-rigidly (point) end (- col2 col1))))))))
1704 | 
1705 | ;; ============================================================
1706 | 
1707 | (provide 'sexp-rewrite)
1708 | ;;; sexp-rewrite.el ends here.
1709 | 


--------------------------------------------------------------------------------