├── .gitignore ├── tests.el ├── license.txt ├── README.md └── shadchen.el /.gitignore: -------------------------------------------------------------------------------- 1 | .#* 2 | *.elc -------------------------------------------------------------------------------- /tests.el: -------------------------------------------------------------------------------- 1 | ;;; tests.el --- tests for shadchen.el 2 | 3 | (require 'shadchen) 4 | (require 'ert) 5 | 6 | 7 | (ert-deftest shadchen-symbol-match-failed () 8 | "Test symbol matching." 9 | (assert 10 | (equal 11 | 10 12 | (match 10 13 | (x x))) 14 | () 15 | "symbol match failed.")) 16 | 17 | (ert-deftest shadchen-match-string () 18 | "Match a string." 19 | (should 20 | (equal "test" 21 | (match "test" 22 | ("test" "test"))))) 23 | 24 | (ert-deftest shadchen-match-string-failed () 25 | "Match a string fails." 26 | (assert 27 | (equal :fail 28 | (match "test" 29 | ("dog" :pass) 30 | (_ :fail))))) 31 | 32 | (ert-deftest shadchen-match-list () 33 | "Matching a list." 34 | (assert 35 | (equal 36 | (list 1 2 3) 37 | (match (list 1 2 3) 38 | ((list x y z) 39 | (list x y z)))))) 40 | 41 | 42 | ;; lexical 43 | 44 | (ert-deftest shadchen-match-lexically () 45 | "lexical-match symbol" 46 | (should 47 | (equal 10 48 | (let 49 | ((f 50 | (lexical-match 10 51 | (x 52 | (lambda () 53 | x))))) 54 | (funcall f))))) 55 | 56 | 57 | (defun-match- test-product (nil acc) 58 | "Return the accumulator." 59 | acc) 60 | 61 | (defun-match test-product ((list-rest hd tl) acc) 62 | "Recur, mult. the acc by the hd." 63 | (recur tl (* hd acc))) 64 | 65 | (defun-match test-product (lst) 66 | "Entry-point: find the product of the numbers in LST." 67 | (recur lst 1)) 68 | 69 | (make-defun-match-unbound 'test-product) 70 | (fmakunbound 'test-product) 71 | (setf (symbol-function 'test-product) nil) 72 | 73 | (test-product (list 1 2 3)) 74 | (eq (get-recur-sigil-for 'x) (get-recur-sigil-for 'x)) 75 | 76 | 77 | ;; Alists and Plists 78 | 79 | (ert-deftest shadchen-match-plist () 80 | "Show plist matching working." 81 | (assert 82 | (equal 83 | (match '(:one 1 :two 2 :three 3) 84 | ((plist :two a) a)) 85 | 2))) ; because that's the value of :two in the plist 86 | 87 | (ert-deftest shadchen-match-alist () 88 | "Show alist matching working." 89 | (assert 90 | (equal 91 | (match '((a . 1)(b . 2)(c . 3)) 92 | ((alist 'c a) a)) 93 | 3))) ; because that's the value of 'c in the alist 94 | 95 | (ert-deftest shadchen-match-struct () 96 | ;; First define a struct 97 | (defstruct shadchen-testpat name version address) 98 | ;; Now let's test a struct object match with shadchen 99 | (equal 100 | (let ((struct-obj (make-shadchen-testpat 101 | :name "test1" 102 | :version "0.0.1" 103 | :address "test1.example.com"))) 104 | (match struct-obj 105 | ((struct shadchen-testpat 106 | name name 107 | version v) (list name v)))) 108 | (list "test1" "0.0.1"))) 109 | 110 | 111 | 112 | ;;; Example tests 113 | 114 | (ert-deftest shadchen-funcall-find-if-example () 115 | "A good example of using `find-if' with funcall." 116 | ;; We want to match only the first string element from the list... 117 | (should 118 | (equal 119 | (match 120 | `(1 2 sym "a string" 2 3 4) 121 | ((funcall (lambda (l) (find-if 'stringp l)) a) a)) 122 | "a string"))) 123 | 124 | ;;; tests.el ends here 125 | -------------------------------------------------------------------------------- /license.txt: -------------------------------------------------------------------------------- 1 | GNU LESSER GENERAL PUBLIC LICENSE 2 | Version 3, 29 June 2007 3 | 4 | Copyright (C) 2007 Free Software Foundation, Inc. 5 | Everyone is permitted to copy and distribute verbatim copies 6 | of this license document, but changing it is not allowed. 7 | 8 | 9 | This version of the GNU Lesser General Public License incorporates 10 | the terms and conditions of version 3 of the GNU General Public 11 | License, supplemented by the additional permissions listed below. 12 | 13 | 0. Additional Definitions. 14 | 15 | As used herein, "this License" refers to version 3 of the GNU Lesser 16 | General Public License, and the "GNU GPL" refers to version 3 of the GNU 17 | General Public License. 18 | 19 | "The Library" refers to a covered work governed by this License, 20 | other than an Application or a Combined Work as defined below. 21 | 22 | An "Application" is any work that makes use of an interface provided 23 | by the Library, but which is not otherwise based on the Library. 24 | Defining a subclass of a class defined by the Library is deemed a mode 25 | of using an interface provided by the Library. 26 | 27 | A "Combined Work" is a work produced by combining or linking an 28 | Application with the Library. The particular version of the Library 29 | with which the Combined Work was made is also called the "Linked 30 | Version". 31 | 32 | The "Minimal Corresponding Source" for a Combined Work means the 33 | Corresponding Source for the Combined Work, excluding any source code 34 | for portions of the Combined Work that, considered in isolation, are 35 | based on the Application, and not on the Linked Version. 36 | 37 | The "Corresponding Application Code" for a Combined Work means the 38 | object code and/or source code for the Application, including any data 39 | and utility programs needed for reproducing the Combined Work from the 40 | Application, but excluding the System Libraries of the Combined Work. 41 | 42 | 1. Exception to Section 3 of the GNU GPL. 43 | 44 | You may convey a covered work under sections 3 and 4 of this License 45 | without being bound by section 3 of the GNU GPL. 46 | 47 | 2. Conveying Modified Versions. 48 | 49 | If you modify a copy of the Library, and, in your modifications, a 50 | facility refers to a function or data to be supplied by an Application 51 | that uses the facility (other than as an argument passed when the 52 | facility is invoked), then you may convey a copy of the modified 53 | version: 54 | 55 | a) under this License, provided that you make a good faith effort to 56 | ensure that, in the event an Application does not supply the 57 | function or data, the facility still operates, and performs 58 | whatever part of its purpose remains meaningful, or 59 | 60 | b) under the GNU GPL, with none of the additional permissions of 61 | this License applicable to that copy. 62 | 63 | 3. Object Code Incorporating Material from Library Header Files. 64 | 65 | The object code form of an Application may incorporate material from 66 | a header file that is part of the Library. You may convey such object 67 | code under terms of your choice, provided that, if the incorporated 68 | material is not limited to numerical parameters, data structure 69 | layouts and accessors, or small macros, inline functions and templates 70 | (ten or fewer lines in length), you do both of the following: 71 | 72 | a) Give prominent notice with each copy of the object code that the 73 | Library is used in it and that the Library and its use are 74 | covered by this License. 75 | 76 | b) Accompany the object code with a copy of the GNU GPL and this license 77 | document. 78 | 79 | 4. Combined Works. 80 | 81 | You may convey a Combined Work under terms of your choice that, 82 | taken together, effectively do not restrict modification of the 83 | portions of the Library contained in the Combined Work and reverse 84 | engineering for debugging such modifications, if you also do each of 85 | the following: 86 | 87 | a) Give prominent notice with each copy of the Combined Work that 88 | the Library is used in it and that the Library and its use are 89 | covered by this License. 90 | 91 | b) Accompany the Combined Work with a copy of the GNU GPL and this license 92 | document. 93 | 94 | c) For a Combined Work that displays copyright notices during 95 | execution, include the copyright notice for the Library among 96 | these notices, as well as a reference directing the user to the 97 | copies of the GNU GPL and this license document. 98 | 99 | d) Do one of the following: 100 | 101 | 0) Convey the Minimal Corresponding Source under the terms of this 102 | License, and the Corresponding Application Code in a form 103 | suitable for, and under terms that permit, the user to 104 | recombine or relink the Application with a modified version of 105 | the Linked Version to produce a modified Combined Work, in the 106 | manner specified by section 6 of the GNU GPL for conveying 107 | Corresponding Source. 108 | 109 | 1) Use a suitable shared library mechanism for linking with the 110 | Library. A suitable mechanism is one that (a) uses at run time 111 | a copy of the Library already present on the user's computer 112 | system, and (b) will operate properly with a modified version 113 | of the Library that is interface-compatible with the Linked 114 | Version. 115 | 116 | e) Provide Installation Information, but only if you would otherwise 117 | be required to provide such information under section 6 of the 118 | GNU GPL, and only to the extent that such information is 119 | necessary to install and execute a modified version of the 120 | Combined Work produced by recombining or relinking the 121 | Application with a modified version of the Linked Version. (If 122 | you use option 4d0, the Installation Information must accompany 123 | the Minimal Corresponding Source and Corresponding Application 124 | Code. If you use option 4d1, you must provide the Installation 125 | Information in the manner specified by section 6 of the GNU GPL 126 | for conveying Corresponding Source.) 127 | 128 | 5. Combined Libraries. 129 | 130 | You may place library facilities that are a work based on the 131 | Library side by side in a single library together with other library 132 | facilities that are not Applications and are not covered by this 133 | License, and convey such a combined library under terms of your 134 | choice, if you do both of the following: 135 | 136 | a) Accompany the combined library with a copy of the same work based 137 | on the Library, uncombined with any other library facilities, 138 | conveyed under the terms of this License. 139 | 140 | b) Give prominent notice with the combined library that part of it 141 | is a work based on the Library, and explaining where to find the 142 | accompanying uncombined form of the same work. 143 | 144 | 6. Revised Versions of the GNU Lesser General Public License. 145 | 146 | The Free Software Foundation may publish revised and/or new versions 147 | of the GNU Lesser General Public License from time to time. Such new 148 | versions will be similar in spirit to the present version, but may 149 | differ in detail to address new problems or concerns. 150 | 151 | Each version is given a distinguishing version number. If the 152 | Library as you received it specifies that a certain numbered version 153 | of the GNU Lesser General Public License "or any later version" 154 | applies to it, you have the option of following the terms and 155 | conditions either of that published version or of any later version 156 | published by the Free Software Foundation. If the Library as you 157 | received it does not specify a version number of the GNU Lesser 158 | General Public License, you may choose any version of the GNU Lesser 159 | General Public License ever published by the Free Software Foundation. 160 | 161 | If the Library as you received it specifies that a proxy can decide 162 | whether future versions of the GNU Lesser General Public License shall 163 | apply, that proxy's public statement of acceptance of any version is 164 | permanent authorization for you to choose that version for the 165 | Library. 166 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Shadchen: A pattern matching library 2 | ==================================== 3 | 4 | shadchen: Noun 5 | matchmaker 6 | from Yiddish 7 | 8 | (note: there is an emacs lisp port of this library 9 | [here][shadchen-el]) 10 | (note: if you are reading this README for the emacs version of the 11 | library, keep in mind that emacs symbols are case sensitive. Symbols 12 | are all lowercase in this library.) 13 | 14 | 15 | I love pattern-matching, which I find to be a great way to combine 16 | destructuring data with type-checking when used in dynamic languages. 17 | If you aren't familiar with how pattern matching works, here is an 18 | example: 19 | 20 | (defun second (lst) 21 | (match lst 22 | ((cons _ (cons x rest)) x))) 23 | 24 | `MATCH` introduces a pattern matching expression, which takes a value, 25 | in this case `LST` and a series of lists, whose first elements are 26 | descriptions of a data structure and whose subsequent elements are 27 | code to execute if the match succeeds. Pattern matching takes the 28 | description of the data and binds the variables that appear therein to 29 | the parts of the data structure they indicate. Above, we match `_` to 30 | the `car` of a list, `x` to the `car` of that list's `cdr`, and `rest` 31 | to the `cdr` of that list. 32 | 33 | If we don't pass in a list, the match fails. (Because of the behavior 34 | of CL's `car` and `cdr`, which return `NIL` on `NIL`, the form `cons` 35 | doesn't enforce a length requirement on the input list, and will 36 | return `NIL` for an empty list. This corresponds with the fact that 37 | in Common Lisp `(car nil)` is `nil` and `(cdr nil)` is `nil`.) 38 | 39 | We might instead write: 40 | 41 | (defun second-of-two (lst) 42 | (match lst 43 | ((list _ x) x))) 44 | 45 | Which returns the second element of a list _only_ when a two element 46 | list is passed in. `MATCH` can take multiple pattern/body sets, in 47 | which case patterns are tried in order until one pattern matches, and 48 | the result of evaluating the associated forms is returned. If no 49 | patterns match, an error is raised. 50 | 51 | Built-in Patterns 52 | ----------------- 53 | 54 | Shadchen supports the following built-in patterns. 55 | 56 | 57 | 58 | Matches anything, binding to that value in the body 59 | expressions. 60 | 61 | 62 | 63 | Matches only when the value is the same keyword. 64 | 65 | 66 | 67 | Matches only when the value is the same number. 68 | 69 | 70 | 71 | Matches only when the value is `string=` is the same string. 72 | 73 | (CONS ) 74 | 75 | Matches any `CONS` cell, or `NIL`, then matches `` and 76 | ``, executing the body in a context where their matches are 77 | bound. If the match value is NIL, then each `PATTERN` matches against 78 | NIL. 79 | 80 | (LIST ... ) 81 | 82 | One may also write 83 | 84 | (LIST ... (TAIL )) 85 | 86 | Where the pattern is matched against the tail of the list. This 87 | is an alternative to LIST-REST. 88 | 89 | Matches a list of length N, then matches each pattern `` to the 90 | elements of that list. 91 | 92 | (LIST-REST ... - to elements in at list, as in the `LIST` pattern. 95 | The final `` is matched against the rest of the list. 96 | 97 | (QUOTE DATUM) 98 | 99 | Only succeeds when `DATUM` is `EQUALP` to the match-value. Binds no 100 | values. 101 | 102 | (AND .. ) 103 | 104 | Tests all `` against the same value, succeeding only when all 105 | patterns match, and binding all variables in all patterns. 106 | 107 | (OR .. ) 108 | 109 | Tries each `` in turn, and succeeds if any `` succeeds. The 110 | body of the matched expression is then executed with that `'s` 111 | bindings. Each sub-pattern in an OR pattern must bind an identical 112 | set of identifiers or an error is raised. 113 | 114 | (? PREDICATE ) 115 | 116 | Succeeds when `(FUNCALL PREDICATE MATCH-VALUE)` is true and when 117 | `` matches the value. Body has the bindings of ``. 118 | 119 | (FUNCALL FUN ) 120 | 121 | Applies `FUN` to the match value, then matches `` against _the 122 | result_. 123 | 124 | (MAYBE-FUNCALL FUN PATTERN) 125 | 126 | Like `FUNCALL` but if the application of `FUN` to the object being 127 | matched against is `*match-fail*` than the match fails, other wise the 128 | match succeeds only when `PATTERN` matches the result. 129 | 130 | (BQ EXPR) 131 | 132 | Matches as if by `BACKQUOTE`. If `EXPR` is an atom, then this is 133 | equivalent to `QUOTE`. If `EXPR` is a list, each element is matches 134 | as in `QUOTE`, unless it is an `(UQ )` form, in which case it 135 | is matched as a pattern. Eg: 136 | 137 | (match (list 1 2 3) 138 | ((BQ (1 (UQ x) 2)) x)) 139 | 140 | Will succeed, binding `X` to 2. 141 | 142 | (match (list 10 2 20) 143 | ((BQ (1 (UQ x) 2)) x)) 144 | 145 | Will fail, since `10` and `1` don't match. 146 | 147 | (values ... ) 148 | 149 | Will match multiple values produced by a `(values ...)` form. 150 | 151 | (let (n1 v1) (n2 v2) ... (nn vn)) 152 | 153 | Not a pattern matching pattern, per se. `let` always succeeds and 154 | produces a context where the bindings are active. This can be used to 155 | provide default alternatives, as in: 156 | 157 | (defun non-nil (x) x) 158 | 159 | (match (list 1) 160 | ((cons hd (or (? #'non-nil tl) 161 | (let (tl '(2 3))))) 162 | (list hd tl))) 163 | 164 | Will result in `(1 (2 3))` but 165 | 166 | (match (list 1 4) 167 | ((cons hd (or (? #'non-nil tl) 168 | (let (tl '(2 3))))) 169 | (list hd tl))) 170 | 171 | Will produce `(1 (4))`. Note that a similar functionality can be 172 | provided with `funcall`. 173 | 174 | (concat P1 ... PN) 175 | 176 | Concat is a powerful string matching pattern. If each pattern is a 177 | string, its behavior is simple: it simply matches the string that is 178 | the concatenation of the pattern strings. 179 | 180 | If any of the patterns are a more complex pattern, then, starting from 181 | the left-most pattern, the shortest substring matching the first 182 | pattern is matched, ad then matching proceeds on the subsequent 183 | patterns and the unmatched part of the string. If this fails, a 184 | longer initial match is searched for. Eg: 185 | 186 | (match "bobcatdog" 187 | ((concat 188 | (and (or "bobcat" "cat") which) 189 | "dog") which)) 190 | 191 | will produce "bobcat", but the pattern will also match "catdog", 192 | returning "cat". 193 | 194 | This is a handy pattern for simple parsers. 195 | 196 | (append P1 ... PN) 197 | 198 | Like `concat` except for lists rather than strings: 199 | 200 | (match 201 | (number-sequence 1 10) 202 | ((append (list 1) _ (list y)) y)) => 10 203 | 204 | the interveening numbers are matched away. 205 | 206 | (must-match pattern) 207 | 208 | This pattern is a bit unusual in that if the value fails to match 209 | `pattern`, then the match will raise an error indicating this fact. 210 | This is useful if you have compound patterns which are strict in some 211 | parts and for which you wish to raise an error, for instance, 212 | 213 | (match `(if (< x 10) true-case false-case nonsense) 214 | ((list 'if (tail (must-match (list a b c)))) 215 | )) 216 | 217 | In the above, we assert that _if_ the head of a list is the symbol 218 | `if`, then the tail must consist of three elements and we want to know 219 | about it immediately if a list with head `if` shows up with a 220 | different tail. 221 | 222 | (must-match pattern fail-binding-pattern expression) 223 | 224 | This is like the pattern above, except in the case that `pattern` 225 | fails to match, `fail-binding-pattern` is matched, and then `expression` 226 | is evaluated and passed to the `error` raising mechanism, coerced to a 227 | string if need be. We migth write the above as 228 | 229 | (match `(if (< x 10) true-case false-case nonsense) 230 | ((list 'if (tail (must-match (list a b c) 231 | actual-tail 232 | (format 233 | "if should have three arguments, but got %s" 234 | actual-tail)))) 235 | )) 236 | 237 | A full shadchen pattern can be used in the fail-binding-pattern, but 238 | usually you are going to provide just a symbol - after all, if the 239 | pattern failed, you don't know much about the value. 240 | 241 | Match-let 242 | --------- 243 | 244 | Match let is a form which behaves identically to a let expression 245 | with two extra features: first, the each variable can be an arbitrary 246 | shadchen pattern and secondly, one can invoke `recur` in any tail 247 | position of the body to induce a trampolined re-entry into the let 248 | expression, so that self-recursive loops can be implemented without 249 | blowing the stack. 250 | 251 | eg: 252 | 253 | (match-let 254 | (((list x y) (list 0 0))) 255 | (if (< (+ x y) 100) 256 | (recur (list (+ x 1) (+ y x))) 257 | (list x y))) 258 | 259 | Will result in `(14 91)`. 260 | 261 | If you like this feature, please let me know if you would like it to 262 | check that `recur` is in tail position. This is an expensive step 263 | which requires walking the body after macro-expansion, which may also 264 | introduce subtle bugs. The upside of doing this is that you avoid the 265 | possibly strange bugs encountered when `recur` is invoked in a 266 | non-tail position. 267 | 268 | User feedback will vary how I approach this. 269 | 270 | defun-match 271 | ----------- 272 | 273 | This special form allows the definition of functions using pattern 274 | matching where bodies can be specified over multiple `defun-match` 275 | invokations: 276 | 277 | 278 | (defun-match- product (nil) 279 | "The empty product." 280 | 1) 281 | 282 | (defun-match product (nil acc) 283 | "Recursion termination." 284 | acc) 285 | 286 | (defun-match product 287 | ((cons (p #'numberp n) 288 | (p #'listp rest)) 289 | (p #'numberp acc)) 290 | "Main body of the product function." 291 | (recur rest (* n acc))) 292 | 293 | (defun-match product (lst) 294 | "Calculate the product of the numbers in LST." 295 | (recur lst 1)) 296 | 297 | Note that different bodies can `recur` to eachother without growing 298 | the stack. Documentation for each body is accumulated, along with the 299 | pattern associated with the body, into the function's complete 300 | documentation. 301 | 302 | The argument list of a `defun-match` form is syntactically equivalent 303 | to the body of a `list` pattern, so you can use `(tail pattern)` to 304 | match against the tail of the arguments passed in. 305 | 306 | 307 | 308 | Extending shadchen 309 | ------------------ 310 | 311 | Users can define their own patterns using the `defpattern` form. For 312 | instance, the behavior of `CONS`, which matches the empty list, may 313 | not be desired. We can define a match which doesn't have this 314 | behavior as: 315 | 316 | (defun non-nil (x) x) 317 | (defpattern cons* (car cdr) 318 | `(? #'non-nil (cons ,car ,cdr))) 319 | 320 | A pattern is a function which takes the arguments passed into the 321 | custom pattern, and expands them into a new pattern in the language of 322 | the built-in pattern-matching. 323 | 324 | We can now say: 325 | 326 | (match (cons 10 11) 327 | ((cons* a b) a)) 328 | 329 | Which will produce 10, but: 330 | 331 | (match nil 332 | ((cons* a b) a)) 333 | 334 | Will raise a no-match error. 335 | 336 | Judicious application of the matchers `AND`, `FUNCALL`, and `?` allow 337 | the definition of arbitrary matchers without exposing the guts of the 338 | matching system. 339 | 340 | * * * 341 | 342 | Copyright 2012, Vincent Toups 343 | This program is distributed under the terms of the GNU Lesser 344 | General Public License (see license.txt). 345 | 346 | [shadchen-el]:https://github.com/VincentToups/emacs-utils/blob/master/shadchen.el 347 | 348 | -------------------------------------------------------------------------------- /shadchen.el: -------------------------------------------------------------------------------- 1 | ;;; shadchen.el --- pattern matching for elisp 2 | 3 | ;; Version: 1.4 4 | ;; Author: Vincent Toups 5 | ;; Maintainer: Vincent Toups 6 | ;; Tags: pattern matching, functional programming 7 | ;; Contributors: Nic Ferrier 8 | 9 | ;;; Copyright 2012, Vincent Toups 10 | ;;; This program is distributed under the terms of the GNU Lesser 11 | ;;; General Public License (see license.txt). 12 | 13 | ;;; Commentary: 14 | ;; Shadchen: A pattern matching library 15 | ;; ==================================== 16 | ;; 17 | ;; shadchen: Noun 18 | ;; matchmaker 19 | ;; from Yiddish 20 | ;; 21 | ;; (note: there is an emacs lisp port of this library 22 | ;; [here][shadchen-el]) 23 | ;; (note: if you are reading this README for the emacs version of the 24 | ;; library, keep in mind that emacs symbols are case sensitive. Symbols 25 | ;; are all lowercase in this library.) 26 | ;; 27 | ;; 28 | ;; I love pattern-matching, which I find to be a great way to combine 29 | ;; destructuring data with type-checking when used in dynamic languages. 30 | ;; If you aren't familiar with how pattern matching works, here is an 31 | ;; example: 32 | ;; 33 | ;; (defun second (lst) 34 | ;; (match lst 35 | ;; ((cons _ (cons x rest)) x))) 36 | ;; 37 | ;; `MATCH` introduces a pattern matching expression, which takes a value, 38 | ;; in this case `LST` and a series of lists, whose first elements are 39 | ;; descriptions of a data structure and whose subsequent elements are 40 | ;; code to execute if the match succeeds. Pattern matching takes the 41 | ;; description of the data and binds the variables that appear therein to 42 | ;; the parts of the data structure they indicate. Above, we match `_` to 43 | ;; the `car` of a list, `x` to the `car` of that list's `cdr`, and `rest` 44 | ;; to the `cdr` of that list. 45 | ;; 46 | ;; If we don't pass in a list, the match fails. (Because of the behavior 47 | ;; of CL's `car` and `cdr`, which return `NIL` on `NIL`, the form `cons` 48 | ;; doesn't enforce a length requirement on the input list, and will 49 | ;; return `NIL` for an empty list. This corresponds with the fact that 50 | ;; in Common Lisp `(car nil)` is `nil` and `(cdr nil)` is `nil`.) 51 | ;; 52 | ;; We might instead write: 53 | ;; 54 | ;; (defun second-of-two (lst) 55 | ;; (match lst 56 | ;; ((list _ x) x))) 57 | ;; 58 | ;; Which returns the second element of a list _only_ when a two element 59 | ;; list is passed in. `MATCH` can take multiple pattern/body sets, in 60 | ;; which case patterns are tried in order until one pattern matches, and 61 | ;; the result of evaluating the associated forms is returned. If no 62 | ;; patterns match, an error is raised. 63 | ;; 64 | ;; Built-in Patterns 65 | ;; ----------------- 66 | ;; 67 | ;; Shadchen supports the following built-in patterns. 68 | ;; 69 | ;; 70 | ;; 71 | ;; Matches anything, binding to that value in the body 72 | ;; expressions. 73 | ;; 74 | ;; 75 | ;; 76 | ;; Matches only when the value is the same keyword. 77 | ;; 78 | ;; 79 | ;; 80 | ;; Matches only when the value is the same number. 81 | ;; 82 | ;; 83 | ;; 84 | ;; Matches only when the value is `string=` is the same string. 85 | ;; 86 | ;; (CONS ) 87 | ;; 88 | ;; Matches any `CONS` cell, or `NIL`, then matches `` and 89 | ;; ``, executing the body in a context where their matches are 90 | ;; bound. If the match value is NIL, then each `PATTERN` matches against 91 | ;; NIL. 92 | ;; 93 | ;; (LIST ... ) 94 | ;; 95 | ;; Matches a list of length N, then matches each pattern `` to the 96 | ;; elements of that list. 97 | ;; 98 | ;; (LIST-REST ... ) 99 | ;; 100 | ;; Matches - to elements in at list, as in the `LIST` pattern. 101 | ;; The final `` is matched against the rest of the list. 102 | ;; 103 | ;; (LIST* ... ) 104 | ;; 105 | ;; LIST* is an alias for LIST-REST. 106 | ;; 107 | ;; (PLIST key ...) 108 | ;; 109 | ;; Matches a plist by matching each against the key it is paired with. 110 | ;; 111 | ;; (ALIST key ...) 112 | ;; 113 | ;; Matches an alist by matching each against the key it is paired with. 114 | ;; 115 | ;; (QUOTE DATUM) 116 | ;; 117 | ;; Only succeeds when `DATUM` is `EQUALP` to the match-value. Binds no 118 | ;; values. 119 | ;; 120 | ;; (AND .. ) 121 | ;; 122 | ;; Tests all `` against the same value, succeeding only when all 123 | ;; patterns match, and binding all variables in all patterns. 124 | ;; 125 | ;; (OR .. ) 126 | ;; 127 | ;; Tries each `` in turn, and succeeds if any `` succeeds. The 128 | ;; body of the matched expression is then executed with that `'s` 129 | ;; bindings. It is up to the user to ensure that the bindings are 130 | ;; relevant to the body. 131 | ;; 132 | ;; (? PREDICATE ) 133 | ;; 134 | ;; Succeeds when `(FUNCALL PREDICATE MATCH-VALUE)` is true and when 135 | ;; `` matches the value. Body has the bindings of ``. 136 | ;; 137 | ;; (FUNCALL FUN ) 138 | ;; 139 | ;; Applies `FUN` to the match value, then matches `` against _the 140 | ;; result_. 141 | ;; 142 | ;; (BQ EXPR) 143 | ;; 144 | ;; Matches as if by `BACKQUOTE`. If `EXPR` is an atom, then this is 145 | ;; equivalent to `QUOTE`. If `EXPR` is a list, each element is matches 146 | ;; as in `QUOTE`, unless it is an `(UQ )` form, in which case it 147 | ;; is matched as a pattern. Eg: 148 | ;; 149 | ;; (match (list 1 2 3) 150 | ;; ((BQ (1 (UQ x) 2)) x)) 151 | ;; 152 | ;; Will succeed, binding `X` to 2. 153 | ;; 154 | ;; (match (list 10 2 20) 155 | ;; ((BQ (1 (UQ x) 2)) x)) 156 | ;; 157 | ;; Will fail, since `10` and `1` don't match. 158 | ;; 159 | ;; (values ... ) 160 | ;; 161 | ;; Will match multiple values produced by a `(values ...)` form. 162 | ;; 163 | ;; (let (n1 v1) (n2 v2) ... (nn vn)) 164 | ;; 165 | ;; Not a pattern matching pattern, per se. `let` always succeeds and 166 | ;; produces a context where the bindings are active. This can be used to 167 | ;; provide default alternatives, as in: 168 | ;; 169 | ;; (defun not-nil (x) x) 170 | ;; 171 | ;; (match (list 1) 172 | ;; ((cons hd (or (? #'non-nil tl) 173 | ;; (let (tl '(2 3))))) 174 | ;; (list hd tl))) 175 | ;; 176 | ;; Will result in `(1 (2 3))` but 177 | ;; 178 | ;; (match (list 1 4) 179 | ;; ((cons hd (or (? #'non-nil tl) 180 | ;; (let (tl '(2 3))))) 181 | ;; (list hd tl))) 182 | ;; 183 | ;; Will produce `(1 (4))`. Note that a similar functionality can be 184 | ;; provided with `funcall`. 185 | ;; 186 | ;; (concat P1 ... PN) 187 | ;; 188 | ;; Concat is a powerful string matching pattern. If each pattern is a 189 | ;; string, its behavior is simple: it simply matches the string that is 190 | ;; the concatenation of the pattern strings. 191 | ;; 192 | ;; If any of the patterns are a more complex pattern, then, starting from 193 | ;; the left-most pattern, the shortest substring matching the first 194 | ;; pattern is matched, ad then matching proceeds on the subsequent 195 | ;; patterns and the unmatched part of the string. Eg: 196 | ;; 197 | ;; (match "bobcatdog" 198 | ;; ((concat 199 | ;; (and (or "bobcat" "cat") which) 200 | ;; "dog") which)) 201 | ;; 202 | ;; will produce "bobcat", but the pattern will also match "catdog", 203 | ;; returning "cat". 204 | ;; 205 | ;; This is a handy pattern for simple parsers. 206 | ;; 207 | ;; (append P1 ... PN) 208 | ;; 209 | ;; Like `concat` except for lists rather than strings: 210 | ;; 211 | ;; (match 212 | ;; (number-sequence 1 10) 213 | ;; ((append (list 1) _ (list y)) y)) => 10 214 | ;; 215 | ;; the interveening numbers are matched away. 216 | ;; 217 | ;; Match-let 218 | ;; --------- 219 | ;; 220 | ;; Match let is a form which behaves identically to a let expression 221 | ;; with two extra features: first, the each variable can be an arbitrary 222 | ;; shadchen pattern and secondly, one can invoke `recur` in any tail 223 | ;; position of the body to induce a trampolined re-entry into the let 224 | ;; expression, so that self-recursive loops can be implemented without 225 | ;; blowing the stack. 226 | ;; 227 | ;; eg: 228 | ;; 229 | ;; (match-let 230 | ;; (((list x y) (list 0 0))) 231 | ;; (if (< (+ x y) 100) 232 | ;; (recur (list (+ x 1) (+ y x))) 233 | ;; (list x y))) 234 | ;; 235 | ;; Will result in `(14 91)`. 236 | ;; 237 | ;; If you like this feature, please let me know if you would like it to 238 | ;; check that `recur` is in tail position. This is an expensive step 239 | ;; which requires walking the body after macro-expansion, which may also 240 | ;; introduce subtle bugs. The upside of doing this is that you avoid the 241 | ;; possibly strange bugs encountered when `recur` is invoked in a 242 | ;; non-tail position. 243 | ;; 244 | ;; User feedback will vary how I approach this. 245 | ;; 246 | ;; defun-match 247 | ;; ----------- 248 | ;; 249 | ;; This special form allows the definition of functions using pattern 250 | ;; matching where bodies can be specified over multiple `defun-match` 251 | ;; invokations: 252 | ;; 253 | ;; 254 | ;; (defun-match- product (nil) 255 | ;; "The empty product." 256 | ;; 1) 257 | ;; 258 | ;; (defun-match product (nil acc) 259 | ;; "Recursion termination." 260 | ;; acc) 261 | ;; 262 | ;; (defun-match product 263 | ;; ((cons (p #'numberp n) 264 | ;; (p #'listp rest)) 265 | ;; (p #'numberp acc)) 266 | ;; "Main body of the product function." 267 | ;; (recur rest (* n acc))) 268 | ;; 269 | ;; (defun-match product (lst) 270 | ;; "Calculate the product of the numbers in LST." 271 | ;; (recur lst 1)) 272 | ;; 273 | ;; Note that different bodies can `recur` to eachother without growing 274 | ;; the stack. Documentation for each body is accumulated, along with the 275 | ;; pattern associated with the body, into the function's complete 276 | ;; documentation. 277 | ;; 278 | ;; 279 | ;; 280 | ;; Extending shadchen 281 | ;; ------------------ 282 | ;; 283 | ;; Users can define their own patterns using the `defpattern` form. For 284 | ;; instance, the behavior of `CONS`, which matches the empty list, may 285 | ;; not be desired. We can define a match which doesn't have this 286 | ;; behavior as: 287 | ;; 288 | ;; (defun non-nil (x) x) 289 | ;; (defpattern cons* (car cdr) 290 | ;; `(? #'non-nil (cons ,car ,cdr))) 291 | ;; 292 | ;; A pattern is a function which takes the arguments passed into the 293 | ;; custom pattern, and expands them into a new pattern in the language of 294 | ;; the built-in pattern-matching. 295 | ;; 296 | ;; We can now say: 297 | ;; 298 | ;; (match (cons 10 11) 299 | ;; ((cons* a b) a)) 300 | ;; 301 | ;; Which will produce 10, but: 302 | ;; 303 | ;; (match nil 304 | ;; ((cons* a b) a)) 305 | ;; 306 | ;; Will raise a no-match error. 307 | ;; 308 | ;; Judicious application of the matchers `AND`, `FUNCALL`, and `?` allow 309 | ;; the definition of arbitrary matchers without exposing the guts of the 310 | ;; matching system. 311 | ;; 312 | ;; * * * 313 | ;; 314 | ;; Copyright 2012, Vincent Toups 315 | ;; This program is distributed under the terms of the GNU Lesser 316 | ;; General Public License (see license.txt). 317 | ;; 318 | ;; [shadchen-el]:https://github.com/VincentToups/emacs-utils/blob/master/shadchen.el 319 | ;; 320 | 321 | (require 'cl) 322 | 323 | (defun shadchen:unique-symbols (lst) 324 | (let ((seen (list))) 325 | (loop for element in lst do 326 | (when (not (memq element seen)) 327 | (push element seen))) 328 | (reverse seen))) 329 | (defstruct match-fail-struct) 330 | 331 | (setq max-lisp-eval-depth 10000) 332 | (setq max-specpdl-size 10000) 333 | 334 | (defvar *match-fail* (make-match-fail-struct)) 335 | (lexical-let ((match-fail *match-fail*)) 336 | (defun match-fail-p (o) 337 | "T only for the match fail singleton." 338 | (eq match-fail o))) 339 | (defvar *shadchen-binding-mode* :dynamic) 340 | (defun adjust-let-for-mode (input) 341 | (case *shadchen-binding-mode* 342 | (:lexical (case input 343 | (let 'lexical-let) 344 | (let* 'lexical-let*) 345 | (t 346 | (error "adjust-let-for-mode expects let or let*.")))) 347 | (:dynamic input))) 348 | 349 | (let ((*shadchen-binding-mode* :lexical)) 350 | (adjust-let-for-mode 'let)) 351 | 352 | (defun shadchen:replace-colons (o with) 353 | (cond ((eq o ':) with) 354 | ((listp o) (mapcar (lambda (o) 355 | (shadchen:replace-colons o with)) o)) 356 | (:otherwise o))) 357 | 358 | (defun shadchen:pprint-to-string (form) 359 | "Pretty print form to a string." 360 | (let ((sym (gensym))) 361 | (replace-regexp-in-string (regexp-quote (format "%s" sym)) 362 | ":" 363 | (with-temp-buffer 364 | (cl-prettyprint (shadchen:replace-colons form sym)) 365 | (buffer-substring (point-min) (point-max)))))) 366 | 367 | (defun non-keyword-symbol (o) 368 | (and (symbolp o) 369 | (not (keywordp o)))) 370 | 371 | (defun match-list-expander* (sub-expressions match-value body) 372 | (cond 373 | ((not sub-expressions) `(if (not ,match-value) (progn ,@body) *match-fail*)) 374 | ((and (= 1 (length sub-expressions)) 375 | (listp (car sub-expressions)) 376 | (eq (car (car sub-expressions)) 'tail)) 377 | `(match1 ,(cadr (car sub-expressions)) ,match-value ,@body)) 378 | (:otherwise 379 | (let ((first-expression (car sub-expressions)) 380 | (list-name (gensym "MATCH-LIST-EXPANDER*-"))) 381 | `(let ((,list-name ,match-value)) 382 | (if (and (listp ,list-name) 383 | ,list-name) 384 | (match1 ,first-expression (car ,list-name) 385 | (match1 (list ,@(cdr sub-expressions)) (cdr ,list-name) 386 | ,@body)) 387 | *match-fail*)))))) 388 | 389 | (defun match-list-expander (match-expression match-value body) 390 | (match-list-expander* (cdr match-expression) match-value body)) 391 | 392 | 393 | (defun match-cons-expander (match-expression match-value body) 394 | (let ((car-match (elt match-expression 1)) 395 | (cdr-match (elt match-expression 2)) 396 | (name (gensym "MATCH-CONS-EXPANDER-"))) 397 | `(let ((,name ,match-value)) 398 | (if (listp ,name) 399 | (match1 ,car-match (car ,name) 400 | (match1 ,cdr-match (cdr ,name) 401 | ,@body)) 402 | *match-fail*)))) 403 | 404 | (defun match-quote-expander (match-expression match-value body) 405 | `(if (equalp ,match-expression ,match-value) (progn ,@body) *match-fail*)) 406 | 407 | (defun match-backquote-expander (match-expression match-value body) 408 | (let ((datum (cadr match-expression))) 409 | (cond 410 | ((not datum) `(progn ,@body)) 411 | ((and (listp datum) 412 | (eq (car datum) 'uq)) 413 | (let ((sub-match (cadr datum))) 414 | `(match1 ,sub-match ,match-value ,@body))) 415 | ((listp datum) 416 | (let ((first-qt (car datum)) 417 | (rest-bq (cdr datum)) 418 | (name (gensym "MATCH-BACKQUOTE-EXPANDER-"))) 419 | `(let ((,name ,match-value)) 420 | (if (and ,name 421 | (listp ,name)) 422 | (match1 (bq ,first-qt) (car ,name) 423 | (match1 (bq ,rest-bq) (cdr ,name) ,@body)) 424 | *match-fail*)))) 425 | (:otherwise 426 | `(match1 ',datum ,match-value ,@body))))) 427 | 428 | (defun match-and-expander* (sub-expressions match-name body) 429 | (cond 430 | ((not sub-expressions) `(progn ,@body)) 431 | (:otherwise 432 | (let ((s1 (car sub-expressions)) 433 | (name (gensym "MATCH-AND-EXPANDER*-"))) 434 | `(match1 ,s1 ,match-name 435 | (match1 (and ,@(cdr sub-expressions)) ,match-name ,@body)))))) 436 | 437 | (defun match-and-expander (match-expression match-value body) 438 | (let ((name (gensym "MATCH-AND-EXPANDER-"))) 439 | `(let ((,name ,match-value)) 440 | ,(match-and-expander* (cdr match-expression) name body)))) 441 | 442 | (defun match-?-expander (match-expression match-value body) 443 | (let ((name (gensym "MATCH-?-EXPANDER-NAME-")) 444 | (f-name (gensym "MATCH-?-EXPANDER-FUNCTION-"))) 445 | (case (length (cdr match-expression)) 446 | (0 (error "MATCH1: MATCH-?-EXPANDER: zero arguments to MATCH-?-EXPANDER. Needs 1 or 2.")) 447 | (1 `(let ((,name ,match-value) 448 | (,f-name ,(cadr match-expression))) 449 | (if (funcall ,f-name ,name) (progn ,@body) *match-fail*))) 450 | (2 `(let ((,name ,match-value) 451 | (,f-name ,(cadr match-expression))) 452 | (if (funcall ,f-name ,name) (match1 ,(elt match-expression 2) ,name ,@body) 453 | *match-fail*))) 454 | (otherwise 455 | (error "MATCH-?-EXPANDER: MATCH-?-EXPANDER takes only 1 or 2 arguments."))))) 456 | 457 | (defun match-values-expander (match-expression match-value body) 458 | (let ((name (gensym "MATCH-VALUES-EXPANDER-"))) 459 | `(let ((,name (multiple-value-list ,match-value))) 460 | (match1 (list ,@(cdr match-expression)) ,name ,@body)))) 461 | 462 | (defun match-funcall-expander (match-expression match-value body) 463 | (assert (and (listp match-expression) (= 3 (length match-expression))) 464 | (match-expression) 465 | "MATCH-FUNCALL-EXPANDER: FUNCALL match expression must have 466 | two terms, a function and a match against the result. Got 467 | %s." match-expression) 468 | (let ((name (gensym "MATCH-FUNCALL-EXPANDER-NAME-")) 469 | (fun-name (gensym "MATCH-FUNCALL-EXPANDER-FUN-NAME-")) 470 | (result-name (gensym "MATCH-FUNCALL-EXPANDER-RESULT-NAME-"))) 471 | `(let* ((,name ,match-value) 472 | (,fun-name ,(cadr match-expression)) 473 | (,result-name (funcall ,fun-name ,name))) 474 | (match1 ,(caddr match-expression) ,result-name ,@body)))) 475 | 476 | (defun match-maybe-funcall-expander (match-expression match-value body) 477 | (assert (and (listp match-expression) (= 3 (length match-expression))) 478 | (match-expression) 479 | "MATCH-FUNCALL-EXPANDER: FUNCALL match expression must have 480 | two terms, a function and a match against the result. Got 481 | %s." match-expression) 482 | (let ((name (gensym "MATCH-FUNCALL-EXPANDER-NAME-")) 483 | (fun-name (gensym "MATCH-FUNCALL-EXPANDER-FUN-NAME-")) 484 | (result-name (gensym "MATCH-FUNCALL-EXPANDER-RESULT-NAME-"))) 485 | `(let* ((,name ,match-value) 486 | (,fun-name ,(cadr match-expression)) 487 | (,result-name (funcall ,fun-name ,name))) 488 | (if (eq ,result-name *match-fail*) 489 | *match-fail* 490 | (match1 ,(caddr match-expression) ,result-name ,@body))))) 491 | 492 | (defvar *extended-patterns* (make-hash-table) "Holds user declared patterns.") 493 | (defun extended-patternp (pattern-head) 494 | "Return T if PATTERN-HEAD indicates a user provided pattern." 495 | (gethash pattern-head *extended-patterns*)) 496 | 497 | (defun match-extended-pattern-expander (match-expression match-value body) 498 | (let* ((pattern-args (cdr match-expression)) 499 | (pattern-fun (gethash (car match-expression) *extended-patterns*)) 500 | (expansion (apply pattern-fun pattern-args))) 501 | `(match1 ,expansion ,match-value ,@body))) 502 | 503 | (defmacro* defpattern (name args &body body) 504 | (let ((stub-args (gensym "args"))) 505 | `(setf (gethash ',name *extended-patterns*) 506 | #'(lambda (&rest ,stub-args) 507 | (destructuring-bind ,args ,stub-args ,@body))))) 508 | 509 | (defun match-literal-string (match-expression match-value body) 510 | `(if (equalp ,match-expression ,match-value) 511 | (progn ,@body) 512 | *match-fail*)) 513 | 514 | (defun match-literal-number (match-expression match-value body) 515 | `(if (equalp ,match-expression ,match-value) 516 | (progn ,@body) 517 | *match-fail*)) 518 | 519 | (defun match-literal-keyword (match-expression match-value body) 520 | `(if (equalp ,match-expression ,match-value) 521 | (progn ,@body) 522 | *match-fail*)) 523 | 524 | (defun match-let-expander (match-expression match-value body) 525 | `(,(adjust-let-for-mode 'let) ,(cdr match-expression) ,@body)) 526 | 527 | ;; (defun match-or-expander (match-expression match-value body) 528 | ;; (cond 529 | ;; ((length=1 (cdr match-expression)) 530 | ;; `(match1 ,(cadr match-expression) ,match-value ,@body)) 531 | ;; (:otherwise 532 | ;; (let* ((forms (cdr match-expression)) 533 | ;; (form (car forms)) 534 | ;; (rest (cdr forms)) 535 | ;; (nm (gensym "MATCH-OR-EXPANDER-NM-"))) 536 | ;; `(let* ((,nm ,match-value) 537 | ;; (result (match1 ,form ,nm ,@body))) 538 | ;; (if (not (eq *match-fail* result)) 539 | ;; result 540 | ;; (match1 (or ,@rest) ,nm ,@body))))))) 541 | 542 | (defun match-or-expander-unsafe (match-expression match-value body) 543 | (let ((-result-holder- (gensym "result-holder-")) 544 | (-value-holder- (gensym "value-holder-"))) 545 | `(let ((,-value-holder- ,match-value) 546 | (,-result-holder- *match-fail*)) 547 | (cond 548 | ,@(loop for pattern in (cdr match-expression) collect 549 | `((progn 550 | (setq ,-result-holder- 551 | (match1 ,pattern ,-value-holder- ,@body)) 552 | (not (eq ,-result-holder- *match-fail*))) 553 | ,-result-holder-)) 554 | (:else *match-fail*))))) 555 | 556 | (defun match-or-expander (match-expression match-value body) 557 | (assert (apply #'equal-by-binding (cdr match-expression)) 558 | (match-expression) 559 | "Or sub-expressions %S contains sub-forms which do not bind identical sets of symbols.") 560 | (match-or-expander-unsafe match-expression match-value body)) 561 | 562 | (defun shadchen:mapcat (f lst) 563 | "Concatenate the results of applying f to each element in lst." 564 | (loop for item in lst append (funcall f item))) 565 | 566 | (defun shadchen:mapcat2 (f lst1 lst2) 567 | "Concatenate the results of applying f to each element in lst." 568 | (loop for item1 in lst1 569 | and item2 in lst2 570 | append (funcall f item1 item2))) 571 | 572 | (defun calc-pattern-bindings-extended (expr) 573 | "Calculate the bound symbols of a user defined pattern." 574 | (let* ((pattern-args (cdr expr)) 575 | (pattern-fun (gethash (car expr) *extended-patterns*)) 576 | (expansion (apply pattern-fun pattern-args))) 577 | (calc-pattern-bindings expansion))) 578 | 579 | (defun calc-backquote-bindings (expr) 580 | "Calculate the bindings for a backquote expression." 581 | (loop for sub in (cdr expr) 582 | when (and (listp sub) 583 | (eq (car sub) 'uq)) 584 | append 585 | (calc-pattern-bindings (cadr sub)))) 586 | 587 | (defun calc-pattern-bindings-list (expr &optional acc) 588 | (cond ((null expr) 589 | acc) 590 | ((and (listp expr) 591 | (listp (car expr)) 592 | (eq 'tail (car (car expr)))) 593 | (append acc (calc-pattern-bindings (cadr (car expr))))) 594 | (t 595 | (calc-pattern-bindings-list (cdr expr) 596 | (append (calc-pattern-bindings (car expr)) acc))))) 597 | 598 | (defun calc-pattern-bindings (expr) 599 | "Given a shadchen pattern EXPR return a list of symbols bound 600 | by that expression." 601 | (cond 602 | ((non-keyword-symbol expr) 603 | (list expr)) 604 | ((vectorp expr) 605 | (calc-pattern-bindings `(list ,@(coerce expr 'list)))) 606 | ((or (not expr) 607 | (symbolp expr) 608 | (numberp expr) 609 | (stringp expr)) nil) 610 | ((extended-patternp (car expr)) 611 | (calc-pattern-bindings-extended expr)) 612 | ((listp expr) 613 | (case (car expr) 614 | (quote nil) 615 | ((and values) 616 | (shadchen:mapcat #'calc-pattern-bindings (cdr expr))) 617 | (list (calc-pattern-bindings-list (cdr expr))) 618 | (cons (append (calc-pattern-bindings (car expr)) 619 | (calc-pattern-bindings (cdr expr)))) 620 | ((? p funcall maybe-funcall) (if (= 2 (length expr)) nil 621 | (calc-pattern-bindings (elt expr 2)))) 622 | (or (calc-pattern-bindings (cadr expr))) 623 | (bq (calc-backquote-bindings expr)) 624 | ((! must-match string number keyword non-keyword-symbol) (calc-pattern-bindings (cadr expr))) 625 | (one-of (calc-pattern-bindings (cadr expr))) 626 | (let (mapcar #'car (cdr expr))))) 627 | (:otherwise 628 | (error "calc-pattern-bindings: unrecognized pattern %S." expr)))) 629 | 630 | (defun symbol->string-for-sort (s) 631 | (symbol-name s)) 632 | 633 | (defun canonical-binding-list (l) 634 | (sort* (shadchen:unique-symbols l) #'string< :key #'symbol->string-for-sort)) 635 | 636 | (defun equal-by-binding2 (p1 p2) 637 | (equal (canonical-binding-list 638 | (calc-pattern-bindings p1)) 639 | (canonical-binding-list 640 | (calc-pattern-bindings p2)))) 641 | 642 | (defun equal-by-binding (&rest patterns) 643 | (cond 644 | ((= 1 (length patterns)) t) 645 | ((= 2 (length patterns)) 646 | (equal-by-binding2 (car patterns) (cadr patterns))) 647 | (t 648 | (and (equal-by-binding2 (car patterns) (cadr patterns)) 649 | (apply #'equal-by-binding (cdr patterns)))))) 650 | 651 | (defun match-one-of-expander (match-expr value-expr body) 652 | (let ((-result- (gensym "result-")) 653 | (-value- (gensym "value-")) 654 | (-element- (gensym "element-"))) 655 | `(let ((,-result- *match-fail*) 656 | (,-value- ,value-expr)) 657 | (when (listp ,-value-) 658 | (loop for ,-element- in ,-value- 659 | do 660 | (setq ,-result- 661 | (match1 ,(cadr match-expr) ,-element- ,@body)) 662 | until 663 | (not (eq *match-fail* ,-result-)))) 664 | ,-result-))) 665 | 666 | (defun match-vector-expander (match-expr match-val body) 667 | (let ((value (gensym))) 668 | `(let ((,value ,match-val)) 669 | (if (vectorp ,value) 670 | (match1 (list ,@(coerce match-expr 'list)) 671 | (coerce ,value 'list) 672 | ,@body) 673 | *match-fail*)))) 674 | 675 | (defun must-match-case (match-expr) 676 | (cond 677 | ((and (listp match-expr) 678 | (= 2 (length match-expr))) 679 | :pattern-only) 680 | ((and (listp match-expr) 681 | (= 4 (length match-expr))) 682 | :pattern+) 683 | (t :unrecognized))) 684 | 685 | (defun match-must-match-expander (match-expr val-expr body) 686 | (case (must-match-case match-expr) 687 | (:pattern-only 688 | (destructuring-bind (_ pattern) match-expr 689 | (let ((sym (gensym))) 690 | (match-must-match-expander 691 | `(must-match 692 | ,pattern 693 | ,sym 694 | (format ,(format "must-match pattern (%S) failed to match %%S" pattern) 695 | ,sym)) 696 | val-expr body)))) 697 | (:pattern+ 698 | (destructuring-bind (_ pattern fail-pattern message-expression) match-expr 699 | (let ((bound-symbols (calc-pattern-bindings pattern)) 700 | (value (gensym)) 701 | (result (gensym))) 702 | `(match1 (funcall 703 | (lambda (,value) 704 | (let ((,result (match1 ,pattern ,value 705 | (list ,@bound-symbols)))) 706 | (if (eq *match-fail* ,result) 707 | (match ,value 708 | (,fail-pattern (let ((,value ,message-expression)) 709 | (if (stringp ,value) 710 | (error ,value) 711 | (error "%S" ,value)))) 712 | (,(gensym) 713 | (error 714 | (format 715 | ,(format "must-match pattern (%S) failed and then the failed-value pattern (%S) also failed on value %%S" 716 | pattern fail-pattern) 717 | ,value)))) 718 | ,result))) 719 | (list ,@bound-symbols)) 720 | ,val-expr 721 | ,@body)))) 722 | (t (error "Unrecognized must-match pattern form %S" match-expr)))) 723 | 724 | (defmacro* match1 (match-expression match-value &body body) 725 | (cond 726 | ((not match-expression) 727 | (match-list-expander '(list) match-value body)) 728 | ((non-keyword-symbol match-expression) 729 | `(,(adjust-let-for-mode 'let) ((,match-expression ,match-value)) 730 | ,@body)) 731 | ((stringp match-expression) 732 | (match-literal-string match-expression match-value body)) 733 | ((numberp match-expression) 734 | (match-literal-number match-expression match-value body)) 735 | ((vectorp match-expression) 736 | (match-vector-expander match-expression match-value body)) 737 | ((keywordp match-expression) 738 | (match-literal-keyword match-expression match-value body)) 739 | ((extended-patternp (car match-expression)) 740 | (match-extended-pattern-expander match-expression match-value body)) 741 | ((listp match-expression) 742 | (if match-expression 743 | (case (car match-expression) 744 | ((! must-match) (match-must-match-expander match-expression match-value body)) 745 | (list (match-list-expander match-expression match-value body)) 746 | (cons (match-cons-expander match-expression match-value body)) 747 | (quote (match-quote-expander match-expression match-value body)) 748 | (and (match-and-expander match-expression match-value body)) 749 | ((? p) (match-?-expander match-expression match-value body)) 750 | (funcall (match-funcall-expander match-expression match-value body)) 751 | (maybe-funcall (match-maybe-funcall-expander match-expression match-value body)) 752 | (or (match-or-expander match-expression match-value body)) 753 | (bq (match-backquote-expander match-expression match-value body)) 754 | (let (match-let-expander match-expression match-value body)) 755 | (values (match-values-expander match-expression match-value body)) 756 | (one-of (match-one-of-expander match-expression match-value body)) 757 | (otherwise "MATCH1: Unrecognized match expression: %s." match-expression)) 758 | (match-list-expander '(list) match-value body))) 759 | (:otherwise (error "MATCH1: Unrecognized match expression: %s." match-expression)))) 760 | 761 | (defmacro* match-helper (current-match-form value &body forms) 762 | (assert (symbolp value) 763 | (value) 764 | "MATCH-HELPER: VALUE must be a symbol! Got %s." value) 765 | (cond 766 | ((not forms) `(error "No Match for %s in %S!" ,value ',current-match-form)) 767 | ((listp forms) 768 | (let ((first-form (car forms))) 769 | (assert (and (listp first-form) 770 | (> (length first-form) 1)) 771 | (first-form current-match-form) 772 | "Each MATCH SUB-FORM must be at least two elements long, a matcher 773 | and an expression to evaluate on match. Got %S instead (in %S)." 774 | first-form current-match-form) 775 | (let ((match-expression (car first-form)) 776 | (match-body-exprs (cdr first-form)) 777 | (result-name (gensym "MATCH-HELPER-RESULT-NAME-"))) 778 | `(let ((,result-name 779 | (match1 ,match-expression ,value ,@match-body-exprs))) 780 | (if (not (eq *match-fail* ,result-name)) ,result-name 781 | (match-helper ,current-match-form ,value ,@(cdr forms))))))))) 782 | 783 | (defvar current-match-form :no-form) 784 | (defmacro* match (value &body forms) 785 | "Attempt to match VALUE against each of the patterns in the CAR of 786 | FORMS. When a match is detected, its subsequent forms are executed as 787 | in a PROGN where the bindings implied by the match are in effect. 788 | 789 | An error is thrown when no matches are found." 790 | (declare (debug (form &rest sexp))(indent 1)) 791 | (let ((name (gensym "MATCH-VALUE-NAME-")) 792 | (current-match-form `(match ,value ,@forms))) 793 | `(let ((,name ,value)) 794 | (match-helper ,current-match-form ,name ,@forms)))) 795 | 796 | (defmacro* lexical-match (value &body forms) 797 | "Attempt to match VALUE against each of the patterns in the CAR of 798 | FORMS. When a match is detected, its subsequent forms are executed as 799 | in a PROGN where the bindings implied by the match are in effect. 800 | 801 | An error is thrown when no matches are found. Bindings are 802 | lexical via cl.el's lexical let. An alternative is to use Emacs 803 | 24's lexical binding mode and use regular match." 804 | (declare (debug (form &rest sexp))) 805 | (let ((*shadchen-binding-mode* :lexical)) 806 | (macroexpand-all `(match ,value ,@forms)))) 807 | 808 | (defmacro* match-lambda (&body forms) 809 | "Like MATCH except the VALUE is curried." 810 | (let ((name (gensym "MATCH-LAMBDA-NAME-"))) 811 | `(function (lambda (,name) (match ,name ,@forms))))) 812 | 813 | (defun length=1 (lst) 814 | "Returns T when LST has one element." 815 | (and (consp lst) 816 | (not (cdr lst)))) 817 | 818 | (defun length=0 (lst) 819 | "Returns T when LST has one element." 820 | (and (consp lst) 821 | (not lst))) 822 | 823 | (defpattern list-rest (&rest patterns) 824 | (let ((n (length patterns))) 825 | (cond ((= n 0) '(list)) 826 | ((= n 1) `(list (tail ,(car patterns)))) 827 | (:otherwise 828 | `(list ,@(reverse (cdr (reverse (copy-list patterns)))) 829 | (tail ,(car (reverse patterns)))))))) 830 | 831 | (defpattern list* (&rest pats) 832 | `(list-rest ,@pats)) 833 | 834 | (defun cl-struct-prepend (s) 835 | (intern (format "cl-struct-%s" s))) 836 | 837 | (defun make-cl-struct-accessor (struct-name slot) 838 | (intern (format "%s-%s" struct-name slot))) 839 | 840 | 841 | (defpattern struct (struct-name &rest fields) 842 | `(and 843 | (? #'vectorp) 844 | (? #'(lambda (x) (> (length x) 0))) 845 | (? #'(lambda (o) 846 | (eq (elt o 0) ',(cl-struct-prepend struct-name)))) 847 | ,@(loop for f in fields collect 848 | `(funcall 849 | #',(make-cl-struct-accessor struct-name (car f)) 850 | ,(cadr f))))) 851 | 852 | (defpattern let1 (symbol value) 853 | `(let (,symbol ,value))) 854 | 855 | (defpattern vector@-no-bounds/type-check (index pattern) 856 | `(funcall 857 | #'(lambda (v) 858 | (aref v ,index)) 859 | ,pattern)) 860 | 861 | (defpattern vector@ (index pattern) 862 | (let ((ix (gensym "vector@-ix")) 863 | (v (gensym "vector@-v"))) 864 | `(and 865 | (? #'vectorp ,v) 866 | (let1 ,ix ,index) 867 | (? #'(lambda (v) 868 | (< (length v) ,ix))) 869 | (vector@-no-bounds/type-check ,ix ,v)))) 870 | 871 | ;; (defpattern one-of (pattern) 872 | ;; `(and 873 | ;; (? #'listp) 874 | ;; (funcall #'length (? (lambda (x) (> x 0)))) 875 | ;; (or (funcall #'car ,pattern) 876 | ;; (funcall #'cdr (one-of ,pattern))))) 877 | 878 | (defpattern one-of-two-lists (pattern) 879 | `(and 880 | (? #'consp) 881 | (or (funcall #'car (one-of ,pattern)) 882 | (funcall #'cdr (one-of ,pattern))))) 883 | 884 | 885 | (defun rotate-list (lst) 886 | (reverse (cons (car lst) (reverse (cdr (copy-list lst)))))) 887 | 888 | (defpattern list% (&rest patterns) 889 | (cond 890 | ((not patterns) `(? (lambda (x) (eq nil x)))) 891 | (:otherwise 892 | (let ((pattern1 (car patterns)) 893 | (rest-patterns (cdr patterns))) 894 | `(and 895 | (? #'listp) 896 | (? (lambda (x) (message (format "%s" x)) (> (length x) 0))) 897 | (or 898 | (and 899 | (funcall #'car ,pattern1) 900 | (funcall #'cdr (list% ,@rest-patterns))) 901 | (list% ,@(rotate-list patterns)))))))) 902 | 903 | (defpattern list%+ (&rest patterns) 904 | (cond 905 | ((not patterns) `(? #'listp)) 906 | (:otherwise 907 | (let ((pattern1 (car patterns)) 908 | (rest-patterns (cdr patterns))) 909 | `(and 910 | (? #'listp) 911 | (? (lambda (x) (message (format "%s" x)) (> (length x) 0))) 912 | (or 913 | (and 914 | (funcall #'car ,pattern1) 915 | (funcall #'cdr (list% ,@rest-patterns))) 916 | (funcall #'rotate-list (list% ,@patterns)))))))) 917 | 918 | (defmacro* match-let ((&rest binders) &body body) 919 | "Like let but the left-hand-side of each binder pair can be a 920 | shadchen-pattern. Within a match-let body, the phrase `(recur 921 | arg1 ...) can be used to trigger a trampolined re-entry into the 922 | match, but only in tail position. 923 | 924 | At the moment, this is not checked at compile time, so unexpected 925 | results can occur if `recur` is used in another position.s" 926 | (declare (debug (sexp &rest form))(indent 1)) 927 | (let ((patterns (mapcar #'car binders)) 928 | (recursion-sigil (gensym "recursion-sigil-")) 929 | (recur-args (gensym "recur-args-")) 930 | (recur-results (gensym "recur-results-")) 931 | (final-result (gensym "final-result-")) 932 | (value-expressions 933 | (mapcar #'cadr binders))) 934 | `(labels ((recur (&rest ,recur-args) 935 | (cons ',recursion-sigil ,recur-args))) 936 | (loop with ,recur-results = 937 | (match (list ,@value-expressions) 938 | ((list ,@patterns) 939 | ,@body)) 940 | while (and (listp ,recur-results) 941 | (eq (car ,recur-results) ',recursion-sigil)) 942 | do 943 | (setq ,recur-results 944 | (match (cdr ,recur-results) 945 | ((list ,@patterns) 946 | ,@body))) 947 | finally 948 | (return ,recur-results))))) 949 | 950 | (defmacro* match-let* (binders &body body) 951 | "Like let* except patterns may appear at any location a binding symbol appears." 952 | (declare (indent 1)) 953 | (cond ((null binders) 954 | `(progn ,@body)) 955 | (t 956 | (let* ((first (car binders)) 957 | (pattern (car first)) 958 | (value-expr (cadr first)) 959 | (rest (cdr binders)) 960 | (anything-else (gensym))) 961 | `(match ,value-expr 962 | (,pattern (match-let* ,rest ,@body)) 963 | (,anything-else 964 | (format "In match-let* %S failed to match pattern %S." ,anything-else ',pattern))))))) 965 | 966 | (defmacro* lexical-match-let ((&rest binders) &body body) 967 | "Like let but the left-hand-side of each binder pair can be a 968 | shadchen-pattern. Within a match-let body, the phrase `(recur 969 | arg1 ...) can be used to trigger a trampolined re-entry into the 970 | match, but only in tail position. 971 | 972 | At the moment, this is not checked at compile time, so unexpected 973 | results can occur if `recur` is used in another position. 974 | 975 | Bindings are lexical via cl.el's lexical-let. An alternative is 976 | to use Emacs 24 & >'s lexical binding mode with regular match-let." 977 | (declare (indent 1)) 978 | (let ((patterns (mapcar #'car binders)) 979 | (recursion-sigil (gensym "recursion-sigil-")) 980 | (recur-args (gensym "recur-args-")) 981 | (recur-results (gensym "recur-results-")) 982 | (final-result (gensym "final-result-")) 983 | (value-expressions 984 | (mapcar #'cadr binders))) 985 | `(labels ((recur (&rest ,recur-args) 986 | (cons ',recursion-sigil ,recur-args))) 987 | (loop with ,recur-results = 988 | (lexical-match (list ,@value-expressions) 989 | ((list ,@patterns) 990 | ,@body)) 991 | while (and (listp ,recur-results) 992 | (eq (car ,recur-results) ',recursion-sigil)) 993 | do 994 | (setq ,recur-results 995 | (match (cdr ,recur-results) 996 | ((list ,@patterns) 997 | ,@body))) 998 | finally 999 | (return ,recur-results))))) 1000 | 1001 | (defvar *match-function-table* (make-hash-table)) 1002 | (defvar *match-function-doc-table* (make-hash-table)) 1003 | (defvar *match-function-name-table* (make-hash-table)) 1004 | (defvar *match-defun-compile-debug-messages* nil) 1005 | 1006 | (defun match-fboundp (symbol) 1007 | "Returns T when symbol is a function and a match function." 1008 | (and (fboundp symbol) 1009 | (gethash symbol *match-function-table*))) 1010 | 1011 | (defmacro* shadchen:let/named (name bindings &body body) 1012 | (let ((arg-names (mapcar #'car bindings)) 1013 | (init-vals (mapcar #'cadr bindings)) 1014 | (results (gensym "results-")) 1015 | (once (gensym "once-")) 1016 | (done (gensym "done-")) 1017 | (sigil (gensym "let/named-sigil-"))) 1018 | `(labels ((,once ,arg-names ,@body) 1019 | (,name ,arg-names 1020 | (list ',sigil ,@arg-names))) 1021 | (loop with 1022 | ,results = (,once ,@init-vals) 1023 | while (and (listp ,results) 1024 | (eq (car ,results) 1025 | ',sigil)) do 1026 | (setq ,results (apply #',once (cdr ,results))) 1027 | finally (return ,results))))) 1028 | 1029 | (defun make-defun-match-unbound (name) 1030 | "Make the match function represented by the symbol NAME unbound." 1031 | (puthash name nil *match-function-doc-table*) 1032 | (puthash name nil *match-function-table*) 1033 | (let ((names (gethash name *match-function-name-table*))) 1034 | (loop for f in names do 1035 | (fmakunbound f))) 1036 | (fmakunbound name)) 1037 | 1038 | (defvar *shadchen-recur-sigils* (make-hash-table) "Ensure 1039 | different bodies of the same shadchen pattern function get the 1040 | same recursion markers.") 1041 | 1042 | (defun get-recur-sigil-for (function-name) 1043 | "Fetch the recursion sigil for the match function function-name." 1044 | (let ((s (gethash function-name *shadchen-recur-sigils*))) 1045 | (if s s 1046 | (progn 1047 | (puthash 1048 | function-name 1049 | (gensym (format "defun-match-recur-sigil-for-%s-" function-name)) 1050 | *shadchen-recur-sigils*) 1051 | (get-recur-sigil-for function-name))))) 1052 | 1053 | ;; (defmacro* defun-match- (name pattern &body body) 1054 | ;; "Identical to defun-match- except makes any previous 1055 | ;; defun-match definitions unbound before defun'ing the function." 1056 | ;; `(progn 1057 | ;; (make-defun-match-unbound ',name) 1058 | ;; (defun-match ,name ,pattern ,@body))) 1059 | 1060 | (defun shadchen:get-doc-from-body (body) 1061 | (if (stringp (car body)) (car body) 1062 | "")) 1063 | 1064 | (defun shadchen:get-body-from-body (body) 1065 | body) 1066 | 1067 | (defun shadchen:make-single-pattern-name (name pattern) 1068 | (intern (replace-regexp-in-string 1069 | (rx (or ")" "(" " ")) 1070 | (lambda (m) 1071 | (cond ((string= m "(") "(") 1072 | ((string= m ")") ")") 1073 | ((string= m " ") " "))) 1074 | (format "%s-%S" name pattern)))) 1075 | 1076 | (defun make-match-defun-main-lambda (name patterns) 1077 | (let ((f-name (gensym "match-sub-fun-")) 1078 | (result (gensym "match-result-")) 1079 | (entry-args (gensym (concat (symbol-name name) "-entry-point-arguments-"))) 1080 | (detect-recur (gensym (concat (symbol-name name) "-recur-detector-"))) 1081 | (funs-to-test (gensym "funs-to-test-")) 1082 | (funs-left-to-test (gensym "funs-left-to-test-"))) 1083 | `(lambda (&rest ,entry-args) 1084 | (let ((,result *match-fail*) 1085 | (,funs-to-test (gethash ',name *match-function-table*)) 1086 | (,funs-left-to-test (gethash ',name *match-function-table*)) 1087 | (,f-name nil)) 1088 | (flet ((recur (&rest args) 1089 | (cons ',(get-recur-sigil-for name) args)) 1090 | (,detect-recur (o) 1091 | (and (consp o) 1092 | (let ((test-result (eq (car o) ',(get-recur-sigil-for name)))) 1093 | test-result)))) 1094 | ,@(if *match-defun-compile-debug-messages* 1095 | `((message "Entering %s." ',name)) 1096 | nil) 1097 | (loop while ,funs-left-to-test 1098 | do 1099 | (setq ,f-name (pop ,funs-left-to-test)) 1100 | ,@(if *match-defun-compile-debug-messages* 1101 | `((message "Trying %s against %S." ,f-name ,entry-args)) 1102 | nil) 1103 | (setq ,result (apply ,f-name ,entry-args)) 1104 | when (and (not (match-fail-p ,result)) 1105 | (not (,detect-recur ,result))) 1106 | do 1107 | ,@(if *match-defun-compile-debug-messages* 1108 | `((message "Terminating with %s." ,result)) 1109 | nil) 1110 | (return ,result) 1111 | when (,detect-recur ,result) 1112 | do 1113 | ,@(if *match-defun-compile-debug-messages* 1114 | `((message "Recurring to %s with %s." ',name ,result)) 1115 | nil) 1116 | (setq ,entry-args (cdr ,result)) 1117 | (setq ,funs-left-to-test ,funs-to-test)) 1118 | (if (match-fail-p ,result) 1119 | (error "%s: Match failure for arguments: %S." ',name ,entry-args) 1120 | ,result)))))) 1121 | 1122 | (defmacro* defun-match- (name patterns &body body) 1123 | (let* ((doc-string (shadchen:get-doc-from-body body)) 1124 | (real-body (shadchen:get-body-from-body body)) 1125 | (compound-name (shadchen:make-single-pattern-name name patterns)) 1126 | (args (gensym (concat "args-" (symbol-name compound-name)))) 1127 | (extended-doc-string (concat (format "%S" patterns) "- " doc-string (format "\n")))) 1128 | `(progn 1129 | (defun ,compound-name (&rest args) 1130 | ,extended-doc-string 1131 | (match1 (list ,@patterns) args ,@body)) 1132 | (setf (gethash ',name *match-function-table*) 1133 | (list #',compound-name)) 1134 | (setf (gethash ',name *match-function-doc-table*) 1135 | ,extended-doc-string) 1136 | (setf (gethash ',name *match-function-name-table*) 1137 | (list ',compound-name)) 1138 | (defalias ',name ,(make-match-defun-main-lambda name patterns) 1139 | ,extended-doc-string)))) 1140 | 1141 | (defmacro* defun-match (name patterns &body body) 1142 | (let* ((doc-string (shadchen:get-doc-from-body body)) 1143 | (real-body (shadchen:get-body-from-body body)) 1144 | (compound-name (shadchen:make-single-pattern-name name patterns)) 1145 | (args (gensym (concat "args-" (symbol-name compound-name)))) 1146 | (extended-doc-string (concat (format "%S" patterns) "- " doc-string (format "\n")))) 1147 | `(progn 1148 | (defun ,compound-name (&rest args) 1149 | ,extended-doc-string 1150 | (match1 (list ,@patterns) args ,@body)) 1151 | (setf (gethash ',name *match-function-table*) 1152 | (append (gethash ',name *match-function-table*) 1153 | (list #',compound-name))) 1154 | (setf (gethash ',name *match-function-doc-table*) 1155 | (concat (gethash ',name *match-function-doc-table*) 1156 | (format "\n") 1157 | ,extended-doc-string)) 1158 | (setf (gethash ',name *match-function-name-table*) 1159 | (cons ',compound-name (gethash ',name *match-function-name-table*))) 1160 | (defalias ',name ,(make-match-defun-main-lambda name patterns) 1161 | (gethash ',name *match-function-doc-table*))))) 1162 | 1163 | 1164 | (defpattern simple-concat (&rest patterns) 1165 | (cond 1166 | ((length=0 patterns) 1167 | "") 1168 | ((length=1 patterns) 1169 | `(? #'stringp ,(car patterns))) 1170 | (:otherwise 1171 | (let* ((the-string (car patterns)) 1172 | (static-len (length the-string))) 1173 | `(and 1174 | (p #'stringp) 1175 | (p (lambda (s) 1176 | (>= (length s) ,static-len))) 1177 | (p 1178 | (lambda (s) 1179 | (string= (substring s 0 ,static-len) ,the-string))) 1180 | (funcall (lambda (s) 1181 | (substring s ,static-len)) 1182 | (concat ,@(cdr patterns)))))))) 1183 | 1184 | 1185 | (defpattern full-concat (pivot &rest patterns) 1186 | (assert (numberp pivot) 1187 | () 1188 | "Pivot should be a number.") 1189 | (cond 1190 | ((length=0 patterns) 1191 | "") 1192 | ((length=1 patterns) 1193 | `(? #'stringp ,(car patterns))) 1194 | (:otherwise 1195 | `(and 1196 | (p (lambda (s) 1197 | (>= (length s) ,pivot))) 1198 | (or 1199 | (and (funcall 1200 | (lambda (s) 1201 | (substring s 0 ,pivot)) 1202 | ,(car patterns)) 1203 | (or 1204 | (funcall 1205 | (lambda (s) 1206 | (substring s ,pivot)) 1207 | (concat ,@(cdr patterns))) 1208 | (full-concat ,(+ pivot 1) ,@patterns))) 1209 | (full-concat ,(+ pivot 1) ,@patterns)))))) 1210 | 1211 | 1212 | 1213 | (defpattern append-helper (head-pattern tail-patterns) 1214 | `(or 1215 | (cons ,head-pattern (append ,@tail-patterns)) 1216 | (and 1217 | (p #'(lambda (l) (cdr l))) 1218 | (funcall 1219 | (lambda (p) 1220 | (let ((candidate (car p)) 1221 | (rest (cdr p))) 1222 | (cons (reverse (cons (car rest) (reverse candidate))) 1223 | (cdr rest)))) 1224 | (append-helper ,head-pattern ,tail-patterns))))) 1225 | 1226 | (defpattern append (&rest patterns) 1227 | (cond 1228 | ((length=0 patterns) nil) 1229 | ((length=1 patterns) 1230 | `(and (p #'listp ,(car patterns)))) 1231 | (:otherwise 1232 | (let ((hd (car patterns)) 1233 | (rest (cdr patterns))) 1234 | `(funcall (lambda (l) 1235 | (cons nil l)) (append-helper ,hd ,rest)))))) 1236 | 1237 | (defmacro* match-lambda (&body body) 1238 | "Produce a lambda accepting a single argument and exectuting 1239 | the matching expression from the body." 1240 | (let ((arg (gensym "arg-"))) 1241 | `(lambda (,arg) 1242 | (match ,arg 1243 | ,@body)))) 1244 | 1245 | (defmacro* shadchen:sequentially (bindings &body body) 1246 | "List comprehension monad form." 1247 | (cond ((null bindings) 1248 | `(progn ,@body)) 1249 | (:else 1250 | (let* ((binding (car bindings)) 1251 | (sym (car binding)) 1252 | (expr (cadr binding))) 1253 | `(loop for ,sym in ,expr append 1254 | (shadchen:sequentially ,(cdr bindings) ,@body)))))) 1255 | 1256 | (defun* shadchen:enumerate-segments (len n &optional (offset 0) acc) 1257 | (cond 1258 | ((= n 0) (reverse acc)) 1259 | ((= n 1) (reverse (cons (list (list offset (- len 1))) acc))) 1260 | ((= n 2) (loop for i from offset to len collect 1261 | (append acc (list (list offset i) 1262 | (list i len)) ))) 1263 | (:else 1264 | (loop for i from offset to len append 1265 | (progn 1266 | (shadchen:enumerate-segments len (- n 1) i 1267 | (cons (list offset i) acc))))))) 1268 | 1269 | (defun shadchen:substrings (string delims) 1270 | (mapcar (lambda (delim) 1271 | (substring string (car delim) (cadr delim))) 1272 | delims)) 1273 | 1274 | (defun shadchen:enumerate-substrings (string n-sub) 1275 | (let ((segments (shadchen:enumerate-segments (length string) n-sub))) 1276 | (reverse (mapcar 1277 | (lambda (segment) 1278 | (shadchen:substrings string segment)) 1279 | segments)))) 1280 | 1281 | ;; (defpattern concat (&rest patterns) 1282 | ;; (cond 1283 | ;; ((length=0 patterns) 1284 | ;; "") 1285 | ;; ((length=1 patterns) 1286 | ;; `(? #'stringp ,(car patterns))) 1287 | ;; (:otherwise 1288 | ;; (cond 1289 | ;; ((stringp (car patterns)) 1290 | ;; `(simple-concat ,@patterns)) 1291 | ;; (:otherwise 1292 | ;; `(full-concat 0 ,@patterns)))))) 1293 | 1294 | (defpattern concat (&rest patterns) 1295 | (let ((-string- (gensym "-string-"))) 1296 | `(and (p #'stringp) 1297 | (funcall 1298 | (lambda (,-string-) 1299 | (shadchen:enumerate-substrings ,-string- ,(length patterns))) 1300 | (one-of (list ,@patterns)))))) 1301 | 1302 | (defun shadchen:non-keyword-symbolp (o) 1303 | (and (symbolp o) 1304 | (not (keywordp o)))) 1305 | 1306 | (defpattern keyword (pattern) 1307 | `(p #'keywordp ,pattern)) 1308 | 1309 | (defpattern symbol (pattern) 1310 | `(p #'symbolp ,pattern)) 1311 | 1312 | (defpattern non-kw-symbol (pattern) 1313 | `(p #'shadchen:non-keyword-symbolp ,pattern)) 1314 | 1315 | (defpattern string (pattern) 1316 | `(p #'stringp ,pattern)) 1317 | 1318 | (defpattern number (pattern) 1319 | `(p #'numberp ,pattern)) 1320 | 1321 | (defpattern equal (value &optional pattern) 1322 | (let ((arg (gensym "arg"))) 1323 | (if pattern `(p #'(lambda (,arg) (equal ,arg ,value)) ,pattern) 1324 | `(p #'(lambda (,arg) (equal ,arg ,value)))))) 1325 | 1326 | (defpattern not-equal (value &optional pattern) 1327 | (let ((arg (gensym "arg"))) 1328 | (if pattern `(p #'(lambda (,arg) (not (equal ,arg ,value))) ,pattern) 1329 | `(p #'(lambda (,arg) (not (equal ,arg ,value))))))) 1330 | 1331 | (defpattern non-null (&optional (pattern (gensym))) 1332 | (let ((arg (gensym))) 1333 | `(p (lambda (,arg) 1334 | (not (null ,arg))) 1335 | ,pattern))) 1336 | 1337 | (defpattern cons* (car-pattern cdr-pattern) 1338 | `(p #'consp (cons ,car-pattern ,cdr-pattern))) 1339 | 1340 | (defstruct monad bind return plus zero) 1341 | (defun copy-monad (m) 1342 | (make-monad 1343 | :bind (monad-bind m) 1344 | :return (monad-return m) 1345 | :plus (monad-plus m) 1346 | :zero (monad-zero m))) 1347 | (defvar monad:id 1348 | (make-monad :bind (lambda (x f) (funcall f x)) 1349 | :return (lambda (x) x))) 1350 | (defvar *current-monad* monad:id) 1351 | 1352 | (defun current-monad-bind (mv mf) 1353 | (funcall (monad-bind *current-monad*) mv mf)) 1354 | (defun current-monad-return (v) 1355 | (funcall (monad-return *current-monad*) v)) 1356 | ;;(defun -> (v) 1357 | ;; (current-monad-return v)) 1358 | (defun current-monad-plus (mv1 mv2) 1359 | (funcall (monad-plus *current-monad*) 1360 | mv1 mv2)) 1361 | (defvar current-monad-zero nil) 1362 | 1363 | (defmacro flet-aliases (binders expressions) 1364 | (let ((gensyms (mapcar (lambda (_) (gensym)) binders)) 1365 | (exprs (mapcar (match-lambda 1366 | ((list _ expr) expr)) binders)) 1367 | (names (mapcar (match-lambda 1368 | ((list name _) name)) binders)) 1369 | (lets (mapcar* #'list gensyms exprs)) 1370 | (flets 1371 | (mapcar* 1372 | (lambda (name gen-name) 1373 | (let ((args (gensym))) 1374 | `(,name (&rest ,args) 1375 | (apply ,gen-name ,args))))))) 1376 | `(let ,lets 1377 | (flet ,flets ,@expressions)))) 1378 | 1379 | (defmacro labels-aliases (binders expressions) 1380 | (let ((gensyms (mapcar (lambda (_) (gensym)) binders)) 1381 | (exprs (mapcar (match-lambda 1382 | ((list _ expr) expr)) binders)) 1383 | (names (mapcar (match-lambda 1384 | ((list name _) name)) binders)) 1385 | (lets (mapcar* #'list gensyms exprs)) 1386 | (flets 1387 | (mapcar* 1388 | (lambda (name gen-name) 1389 | (let ((args (gensym))) 1390 | `(,name (&rest ,args) 1391 | (apply ,gen-name ,args))))))) 1392 | `(let ,lets 1393 | (labels ,flets ,@expressions)))) 1394 | 1395 | (eval-when (load compile eval) 1396 | (defvar shadchen:absent 'e5671794bf87ebab2a0d5e0ded530e68) 1397 | (defun shadchen:absent (x) 1398 | (eq x shadchen:absent)) 1399 | (defun shadchen:not-absent (x) 1400 | (not (shadchen:absent x))) 1401 | (defun-match- shadchen:all-absent (nil) 1402 | t) 1403 | (defun-match shadchen:all-absent ((list hd (tail tl))) 1404 | (if (shadchen:absent hd) 1405 | (recur tl) 1406 | nil)) 1407 | (defpattern shadchen:monad-bind (pattern expr) 1408 | `(or (list :bind ,pattern ,expr) 1409 | (list ,pattern '<- ,expr))) 1410 | (defpattern shadchen:monad-let (pattern expr) 1411 | `(or (list :let ,pattern ,expr) 1412 | (list ,pattern '= ,expr)))) 1413 | 1414 | (defmacro* monadically-helper (&body expressions) 1415 | (match expressions 1416 | ((list (shadchen:monad-bind pattern expr) (tail subsequents)) 1417 | (let ((val (gensym))) 1418 | `(current-monad-bind 1419 | ,expr 1420 | (lambda (,val) 1421 | (match ,val 1422 | (,pattern ,(if subsequents `(monadically-helper ,@subsequents) val)) 1423 | (,val (error "monadically pattern <%s> failed to match %s during monadic-bind." ',pattern ,val))))))) 1424 | ((list (shadchen:monad-let pattern expr) (tail subsequents)) 1425 | (let ((val (gensym))) 1426 | `(match ,expr 1427 | ((and ,val ,pattern) ,(if subsequents `(monadically-helper ,@subsequents) val)) 1428 | (,val (error "monadically pattern <%s> failed to match %s during non-monadic bind." ',pattern ,val))))) 1429 | ((list (list :aside (tail expressions)) rest0 (tail rest)) 1430 | `(progn ,@expressions 1431 | (monadically-helper ,rest0 ,@rest))) 1432 | ((list expr subsequents0 (tail subsequents)) 1433 | (let ((val (gensym))) 1434 | `(current-monad-bind ,expr 1435 | (lambda (,val) 1436 | (monadically-helper subsequents0 ,@subsequents))))) 1437 | ((list expr) 1438 | expr))) 1439 | 1440 | 1441 | 1442 | 1443 | (defmacro* monadically ((&key 1444 | (monad shadchen:absent) 1445 | (bind shadchen:absent) 1446 | (return shadchen:absent) 1447 | (plus shadchen:absent) 1448 | (zero shadchen:absent)) 1449 | &body body) 1450 | (cond 1451 | ((shadchen:all-absent (list monad bind return plus zero)) 1452 | `(symbol-macrolet ((current-monad-zero '(monad-zero *current-monad*))) 1453 | (monadically-helper ,@body))) 1454 | (:otherwise 1455 | (let ((-monad (gensym))) 1456 | `(let ((,-monad (copy-monad ,(if (shadchen:absent monad) `*current-monad* 1457 | monad)))) 1458 | ,@(if (shadchen:absent bind) nil (list `(setf (monad-bind ,-monad) ,bind))) 1459 | ,@(if (shadchen:absent return) nil (list `(setf (monad-return ,-monad) ,return))) 1460 | ,@(if (shadchen:absent plus) nil (list `(setf (monad-plus ,-monad) ,plus))) 1461 | ,@(if (shadchen:absent zero) nil (list `(setf (monad-zero ,-monad) ,zero))) 1462 | (let ((*current-monad* ,-monad)) 1463 | (monadically-helper ,@body))))))) 1464 | 1465 | (defvar list-monad 1466 | (make-monad :bind 1467 | (lambda (mv mf) 1468 | (shadchen:mapcat mf mv)) 1469 | :return #'list 1470 | :plus #'append 1471 | :zero nil)) 1472 | 1473 | (defun Just (x) 1474 | `(Just ,x)) 1475 | (defun None (&optional reasons) 1476 | `(None ,reasons)) 1477 | 1478 | (eval-when (load compile eval) 1479 | (defpattern Just (&optional (pattern (gensym))) 1480 | `(list 'Just ,pattern)) 1481 | (defpattern None (&optional (pattern (gensym))) 1482 | `(list 'None ,pattern))) 1483 | 1484 | (defvar maybe-monad 1485 | (make-monad :bind (lambda (mv mf) 1486 | (match mv 1487 | ((Just value) 1488 | (funcall mf value)) 1489 | ((None reason) 1490 | mv))) 1491 | :return (lambda (v) (Just v)) 1492 | :plus (lambda (mv1 mv2) 1493 | (match mv1 1494 | ((Just value) 1495 | mv2) 1496 | ((None reason) 1497 | mv1))) 1498 | :zero (None))) 1499 | 1500 | (defun shadchen:kw->symbol (k) 1501 | (assert (keywordp k)) 1502 | (intern (substring (symbol-name k) 1))) 1503 | 1504 | (eval-when (compile load eval) (defpattern keys (&rest kp-pairs) 1505 | (let ((db-expr '(&key)) 1506 | (bound-symbols nil) 1507 | (patterns nil) 1508 | (datum (gensym "datum"))) 1509 | (loop for (k p . rest) on kp-pairs by #'cddr 1510 | do 1511 | (let ((temp (gensym "temp")) 1512 | (key-as-sym (shadchen:kw->symbol k))) 1513 | (setq bound-symbols (append bound-symbols (list key-as-sym))) 1514 | (setq db-expr (append db-expr (list key-as-sym))) 1515 | (setq patterns (append patterns (list p))))) 1516 | `(maybe-funcall 1517 | (lambda (,datum) 1518 | (condition-case nil 1519 | (destructuring-bind ,db-expr ,datum 1520 | (list ,@bound-symbols)) 1521 | (error *match-fail*))) 1522 | (list ,@patterns))))) 1523 | 1524 | 1525 | ;; A few obvious EmacsLisp extras 1526 | 1527 | (defun shadchen/extract (key type) 1528 | "Return a func to extract KEY from TYPE. 1529 | 1530 | TYPE is either `:alist' or `:plist'." 1531 | (lexical-let ((typ type) 1532 | (k key)) 1533 | (lambda (kvlist) 1534 | (case typ 1535 | (:struct (apply (symbol-function k) (list kvlist))) 1536 | (:plist (plist-get kvlist k)) 1537 | (:alist (cdr-safe (assoc k kvlist))))))) 1538 | 1539 | (defpattern plist (&rest kv-pairs) 1540 | `(and ,@(loop for (k v . rest) on kv-pairs by #'cddr 1541 | collect 1542 | `(funcall (shadchen/extract ,k :plist) ,v)))) 1543 | 1544 | (defpattern alist (&rest kv-pairs) 1545 | `(and ,@(loop for (k v . rest) on kv-pairs by #'cddr 1546 | collect 1547 | `(funcall (shadchen/extract ,k :alist) ,v)))) 1548 | 1549 | 1550 | (defun shadchen/struct-field (struct field) 1551 | "Helper to access FIELD in STRUCT." 1552 | (concat (symbol-name struct) "-" (symbol-name field))) 1553 | 1554 | (defpattern struct (name &rest accessor-pairs) 1555 | `(and (? (lambda (v) 1556 | (eq (aref v 0) 1557 | (intern (concat "cl-struct-" ,(symbol-name name))))) _) 1558 | ,@(loop for (k v . rest) on accessor-pairs by #'cddr 1559 | collect 1560 | `(funcall (shadchen/extract 1561 | ,(shadchen/struct-field name k) :struct) 1562 | ,v)))) 1563 | 1564 | (provide 'shadchen) 1565 | 1566 | ;;; shadchen.el ends here 1567 | --------------------------------------------------------------------------------