From 800a03e0c601c18ae533a7067652c990bb237676 Mon Sep 17 00:00:00 2001
From: Ed Langley <el-github@elangley.org>
Date: Wed, 30 Sep 2020 15:48:03 -0700
Subject: [PATCH] =?UTF-8?q?feat:=20add=20=E2=80=A2=20compose=20operator?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 lens.lisp             | 11 +++++----
 wrapped-sequence.lisp | 53 +++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 60 insertions(+), 4 deletions(-)
 create mode 100644 wrapped-sequence.lisp

diff --git a/lens.lisp b/lens.lisp
index 5c3250a..146f7d7 100644
--- a/lens.lisp
+++ b/lens.lisp
@@ -93,10 +93,10 @@ operator):
 
     (== (view lens (set lens value rec))
         value)
- 
+
     (== (set lens (view lens rec) rec)
         rec)
- 
+
     (== (set lens value2 (set lens value1 rec))
         (set lens value2 rec))
 
@@ -234,11 +234,12 @@ contain the new value at the location focused by the lens."
            #:compress-runs #:combine-matching-lists #:sorted #:applicable-when
            #:of-length #:of-min-length #:of-max-length #:transform-head
            #:maximizing #:zipping #:applying #:splice-elt #:transform-elt #:denest
-           #:op #:defalias #:<> #:<>1))
+           #:op #:defalias #:<> #:<>1
+           #:•))
 (in-package :data-lens)
 
 
-(declaim 
+(declaim
  (inline data-lens:over data-lens:transform-tail
          data-lens:applicable-when data-lens:of-min-length
          data-lens:on data-lens:over data-lens:slice
@@ -524,3 +525,5 @@ contain the new value at the location focused by the lens."
 
 (defmacro <>1 (&rest funs)
   `(alexandria:compose ,@funs))
+(defmacro • (&rest funs)
+  `(alexandria:compose ,@funs))
diff --git a/wrapped-sequence.lisp b/wrapped-sequence.lisp
new file mode 100644
index 0000000..a773255
--- /dev/null
+++ b/wrapped-sequence.lisp
@@ -0,0 +1,53 @@
+(defpackage :data-lens.wrapped-sequence
+  (:use :cl )
+  (:export ))
+(in-package :data-lens.wrapped-sequence)
+
+(defgeneric underlying (wrapper)
+  (:documentation "Return the underlying object of a wrapper"))
+
+(defclass tagged-sequence (standard-object sequence)
+  ((%underlying-sequence :initarg :underlying :accessor underlying)
+   (%key-fn :initarg :key :reader key)
+   (%invert-key :initarg :invert-key :reader invert-key)))
+
+(defmethod sb-sequence:length ((sequence tagged-sequence))
+  (length (underlying sequence)))
+
+(defmethod sb-sequence:elt ((sequence tagged-sequence) index)
+  (funcall (key sequence)
+           (elt (underlying sequence)
+                index)))
+
+(defmethod (setf sb-sequence:elt) (new-value (sequence tagged-sequence) index)
+  (setf (elt (underlying sequence)
+             index)
+        (funcall (invert-key sequence)
+                 (elt (underlying sequence)
+                      index)
+                 new-value)))
+
+(defmethod sb-sequence:adjust-sequence ((sequence tagged-sequence) length
+                                        &rest r
+                                        &key initial-element initial-contents)
+  (declare (ignore initial-element initial-contents))
+  (make-instance 'tagged-sequence
+                 :underlying (apply #'sb-sequence:adjust-sequence
+                                    (copy-seq (underlying sequence)) length
+                                    r)
+                 :key-fn (key sequence)
+                 :invert-key (invert-key sequence)))
+
+(defmethod sb-sequence:make-sequence-like
+    ((sequence tagged-sequence) length &rest r)
+  (apply #'sb-sequence:adjust-sequence sequence length r))
+
+(defun wrap-sequence (seq key-fn invert-key-fn)
+  (if invert-key-fn
+      (make-instance 'tagged-sequence
+                     :underlying seq
+                     :key key-fn
+                     :invert-key invert-key-fn)
+      (make-instance 'tagged-sequence
+                     :underlying seq
+                     :key key-fn)))