feat: add fset integration in system :data-lens+fset

data-lens+fset.asd

@@ -0,0 +1,12 @@
+(in-package :asdf-user)
+
+(asdf:defsystem #:data-lens+fset
+  :author "Edward Langley <el-cl@elangley.org>"
+  :license "Apache v2"
+  :depends-on (:data-lens
+               :data-lens/transducers
+               :fset
+               :named-readtables)
+  :serial t
+  :in-order-to ((test-op (test-op :data-lens/test)))
+  :components ((:file "data-lens-fset")))

data-lens-fset.lisp

@@ -0,0 +1,110 @@
+(defpackage :fwoar.data-lens-fset
+  (:use :cl )
+  (:export
+   #:make-seq-lens
+   #:make-bag-lens
+   #:make-set-lens))
+(in-package :fwoar.data-lens-fset)
+
+(named-readtables:in-readtable fset:fset-readtable)
+
+(defmethod data-lens.transducers.internals:reduce-generic ((set fset:set) (func function) init)
+  (fset:reduce func set :initial-value init))
+(defmethod data-lens.transducers.internals:builder-for-input ((seq fset:set))
+  (values 'fset-set-builder
+          seq))
+(defmethod data-lens.transducers.internals:stepper ((seq (eql 'fset-set-builder)))
+  (data-lens.transducers:transducer-lambda
+    ((acc next)
+     (fset:with acc next))))
+(defmethod data-lens:functionalize ((it fset:set))
+  (lambda (key)
+    (nth-value 1 (fset:lookup it key))))
+(defmethod data-lens:extract-key ((it fset:set) key)
+  (nth-value 1 (fset:lookup it key)))
+(defun make-set-lens (item)
+  "A lens for updating a set"
+  (lambda (cb)
+    (lambda (set)
+      (data-lens.lenses:fmap (lambda (new)
+                               (fset:with (fset:less set item) new))
+                             (funcall cb (nth-value 1 (fset:lookup set item)))))))
+(defmethod data-lens.lenses:generic-lens ((rec fset:set) cb loc)
+  (funcall (funcall (make-set-lens loc)
+                    cb)
+           rec))
+
+(defmethod data-lens.transducers.internals:reduce-generic ((seq fset:seq) (func function) init)
+  (fset:reduce func seq :initial-value init))
+(defmethod data-lens.transducers.internals:builder-for-input ((seq fset:seq))
+  (values 'fset-seq-builder
+          seq))
+(defmethod data-lens.transducers.internals:stepper ((seq (eql 'fset-seq-builder)))
+  (data-lens.transducers:transducer-lambda
+    ((acc next)
+     (fset:with-last acc next))))
+(defmethod data-lens:functionalize ((it fset:seq))
+  (lambda (key)
+    (fset:lookup it key)))
+(defmethod data-lens:extract-key ((it fset:seq) key)
+  (fset:lookup it key))
+(defmethod data-lens.lenses:fmap (function (data fset:seq)))
+(defun make-seq-lens (index)
+  "A lens for updating a sequence"
+  (check-type index (integer 0))
+  (lambda (cb)
+    (lambda (seq)
+      (data-lens.lenses:fmap (lambda (new)
+                               (fset:with seq index new))
+                             (funcall cb (fset:lookup seq index))))))
+(defmethod data-lens.lenses:generic-lens ((rec fset:seq) cb (loc integer))
+  (funcall (funcall (make-seq-lens loc)
+                    cb)
+           rec))
+
+
+(defmethod data-lens.transducers.internals:builder-for-input ((map fset:map))
+  (values 'fset-map-builder
+          map))
+(defmethod data-lens.transducers.internals:stepper ((map (eql 'fset-map-builder)))
+  (data-lens.transducers:transducer-lambda
+    ((acc next)
+     (destructuring-bind (k v) next
+       (fset:with acc k v)))))
+(defmethod data-lens:functionalize ((it fset:map))
+  (lambda (key)
+    (fset:lookup it key)))
+(defmethod data-lens:extract-key ((it fset:map) key)
+  (fset:lookup it key))
+(defun make-map-lens (key)
+  (lambda (cb)
+    (lambda (map)
+      (data-lens.lenses:fmap (lambda (new)
+                               (fset:with map key new))
+                             (funcall cb (fset:lookup map key))))))
+(defmethod data-lens.lenses:generic-lens ((rec fset:map) cb loc)
+  (funcall (funcall (make-map-lens loc)
+                    cb)
+           rec))
+
+
+(defmethod data-lens.transducers.internals:builder-for-input ((bag fset:bag))
+  (values 'fset-bag-builder
+          bag))
+(defmethod data-lens.transducers.internals:stepper ((bag (eql 'fset-bag-builder)))
+  (data-lens.transducers:transducer-lambda
+    ((acc next)
+     (:printv (fset:with acc next)))))
+(defmethod data-lens:functionalize ((it fset:bag))
+  (lambda (key)
+    (fset:multiplicity it key)))
+(defmethod data-lens:extract-key ((it fset:bag) key)
+  (let ((m (fset:multiplicity it key)))
+    (values key
+            m)))
+(defun make-bag-lens (item)
+  (make-set-lens item))
+(defmethod data-lens.lenses:generic-lens ((rec fset:bag) cb loc)
+  (funcall (funcall (make-set-lens loc)
+                    cb)
+           rec))

package.lisp

@@ -7,7 +7,10 @@
   (:shadow :set)
   (:use :cl)
   (:export #:over #:set #:view #:make-alist-lens #:make-plist-lens
-           #:make-hash-table-lens #:make-list-lens))
+           #:make-hash-table-lens #:make-list-lens
+           #:make-lens
+           #:generic-lens
+           #:fmap))
 
 (defpackage :data-lens
   (:use :cl)
@@ -21,7 +24,8 @@
            #:transform-elt #:denest #:op #:defalias #:<> #:<>1 #:== #:•
            #:∘ #:suffixp #:functionalize #:inc #:group-by #:keys
            #:conj #:disj #:delay #:of-type #:transform #:calling*
-           #:calling #:hash-join #:tap #:x-group))
+           #:calling
+           #:closing))
 
 (defpackage :data-lens.transducers.internals
   (:use :cl)
@@ -38,4 +42,5 @@
            #:hash-table-builder #:vector-builder #:list-builder
            #:collecting #:mv-mapping #:mv-selecting #:hash-table-select
            #:mv-filtering #:mapcatting #:lazy-sequence
-           #:compressing-runs #:iota #:repeating #:repeating* #:into))
+           #:compressing-runs #:iota #:repeating #:repeating* #:into
+           #:transducer-lambda))

transducer-protocol.lisp

@@ -22,6 +22,17 @@
 
 (defgeneric init (client))
 (defgeneric stepper (client))
+(defmacro transducer-lambda (&body (((two-arg-acc two-arg-next) &body two-arg-body)
+                                    &optional (((one-arg-arg) &body one-arg-body)
+                                               '((it) it))))
+  (alexandria:with-gensyms (arg1 arg2 next-sym-p)
+    `(lambda (,arg1 &optional (,arg2 nil ,next-sym-p))
+       (if ,next-sym-p
+           (let ((,two-arg-acc ,arg1)
+                 (,two-arg-next ,arg2))
+             ,@two-arg-body)
+           (let ((,one-arg-arg ,arg1))
+             ,@one-arg-body)))))
 (defgeneric unwrap (client obj)
   (:method (client obj) obj))
 (defgeneric builder-for-input (seq)