Browse code
Add an actual implementation of lenses
Ed Langley authored on 29/04/2019 04:11:24Showing 1 changed files
| ... | ... |
@@ -1,3 +1,78 @@ |
| 1 |
+(defpackage :data-lens.lenses |
|
| 2 |
+ (:shadow :set) |
|
| 3 |
+ (:use :cl)) |
|
| 4 |
+(in-package :data-lens.lenses) |
|
| 5 |
+ |
|
| 6 |
+(defun make-alist-lens (key) |
|
| 7 |
+ (lambda (cb) |
|
| 8 |
+ (lambda (alist) |
|
| 9 |
+ (let ((old-value (serapeum:assocdr key alist))) |
|
| 10 |
+ (cons (cons key (funcall cb old-value)) |
|
| 11 |
+ alist))))) |
|
| 12 |
+ |
|
| 13 |
+(defun make-plist-lens (key) |
|
| 14 |
+ (lambda (cb) |
|
| 15 |
+ (lambda (plist) |
|
| 16 |
+ (let ((old-value (getf plist key))) |
|
| 17 |
+ (list* key (funcall cb old-value) |
|
| 18 |
+ plist))))) |
|
| 19 |
+ |
|
| 20 |
+(defun make-hash-table-lens (key) |
|
| 21 |
+ (lambda (cb) |
|
| 22 |
+ (lambda (old-hash) |
|
| 23 |
+ (let ((old-value (gethash key old-hash))) |
|
| 24 |
+ (fw.lu:prog1-bind (new-hash (alexandria:copy-hash-table old-hash)) |
|
| 25 |
+ (setf (gethash key new-hash) |
|
| 26 |
+ (funcall cb old-value))))))) |
|
| 27 |
+ |
|
| 28 |
+;; imagine a lens here that uses the MOP to immutably update a class... |
|
| 29 |
+ |
|
| 30 |
+(defun over (lens cb rec) |
|
| 31 |
+ "Given a lens, a callback and a record, apply the lens to the |
|
| 32 |
+record, transform it by the callback and return copy of the record, |
|
| 33 |
+updated to contain the result of the callback. This is the fundamental |
|
| 34 |
+operation on a lens and SET and VIEW are implemented in terms of it. |
|
| 35 |
+ |
|
| 36 |
+A lens is any function of the form (lambda (fun) (lambda (rec) ...)) |
|
| 37 |
+that obeys the lens laws (where == is some reasonable equality |
|
| 38 |
+operator): |
|
| 39 |
+ |
|
| 40 |
+ (== (view lens (set lens value rec)) |
|
| 41 |
+ value) |
|
| 42 |
+ |
|
| 43 |
+ (== (set lens (view lens rec) rec) |
|
| 44 |
+ rec) |
|
| 45 |
+ |
|
| 46 |
+ (== (set lens value2 (set lens value1 rec)) |
|
| 47 |
+ (set lens value2 rec)) |
|
| 48 |
+ |
|
| 49 |
+If these conditions are met, (over (data-lens:<>1 lens1 lens2) ...) is |
|
| 50 |
+equivalent to using lens2 to focus the part lens1 focuses: note that |
|
| 51 |
+composition is \"backwards\" from what one might expect: this is |
|
| 52 |
+because composition composes the wrapper lambdas and applies the |
|
| 53 |
+lambda that actually pulls a value out of a record later." |
|
| 54 |
+ |
|
| 55 |
+ (funcall (funcall lens cb) |
|
| 56 |
+ rec)) |
|
| 57 |
+ |
|
| 58 |
+(defun set (lens value rec) |
|
| 59 |
+ "Given a lens, a value and a rec, immutably update the rec to |
|
| 60 |
+contain the new value at the location focused by the lens." |
|
| 61 |
+ (over lens |
|
| 62 |
+ (lambda (_) |
|
| 63 |
+ (declare (ignore _)) |
|
| 64 |
+ value) |
|
| 65 |
+ rec)) |
|
| 66 |
+ |
|
| 67 |
+(defun view (lens rec) |
|
| 68 |
+ "Given a lens and a rec, return the focused value" |
|
| 69 |
+ (over lens |
|
| 70 |
+ (lambda (value) |
|
| 71 |
+ (return-from view |
|
| 72 |
+ value)) |
|
| 73 |
+ rec)) |
|
| 74 |
+ |
|
| 75 |
+ |
|
| 1 | 76 |
(defpackage :data-lens |
| 2 | 77 |
(:use :cl) |
| 3 | 78 |
(:import-from #:serapeum #:op #:defalias) |
| ... | ... |
@@ -10,6 +85,7 @@ |
| 10 | 85 |
#:defalias #:<> #:<>1)) |
| 11 | 86 |
(in-package :data-lens) |
| 12 | 87 |
|
| 88 |
+ |
|
| 13 | 89 |
(declaim |
| 14 | 90 |
(inline data-lens:over data-lens:transform-tail |
| 15 | 91 |
data-lens:applicable-when data-lens:of-min-length |
| ... | ... |
@@ -17,6 +93,7 @@ |
| 17 | 93 |
data-lens:compress-runs data-lens:combine-matching-lists |
| 18 | 94 |
data-lens:juxt data-lens:element data-lens:sorted)) |
| 19 | 95 |
|
| 96 |
+;;; TODO: consider making this wrap defalias? |
|
| 20 | 97 |
(defmacro shortcut (name function &body bound-args) |
| 21 | 98 |
`(eval-when (:load-toplevel :compile-toplevel :execute) |
| 22 | 99 |
(setf (fdefinition ',name) |