chore: remote-tracking branch 'gh/master'

.github/workflows/test.yml

@@ -73,4 +73,4 @@ jobs:
                --eval "(handler-case (ql:quickload :data-lens/test) (error (c) (format t \"~a\" c) (uiop:quit 44)))" \
                --eval "(handler-case (asdf:test-system :data-lens) (error (c) (format t \"~a\" c) (uiop:quit 45)))" \
                --eval "(handler-case (asdf:test-system :data-lens/transducers) (error (c) (format t \"~a\" c) (uiop:quit 46)))" \
-               --quit
+               --quit 2>&1 | grep -v '^;'

data-lens+fset.asd

@@ -0,0 +1,11 @@
+(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)
+  :serial t
+  :in-order-to ((test-op (test-op :data-lens/test)))
+  :components ((:file "data-lens-fset")))

data-lens-fset.lisp

@@ -0,0 +1,117 @@
+(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 ((set fset:set))
+  (lambda (it)
+    (fset:contains? set it)))
+(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:reduce-generic ((map fset:map) (func function) init)
+  (fset:reduce (lambda (acc k v)
+                 (funcall func acc (list k v)))
+               map
+               :initial-value init))
+(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)
+     (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))
+

data-lens.asd

@@ -8,9 +8,7 @@
   :author "Edward Langley <el-cl@elangley.org>"
   :license "Apache v2"
   :depends-on (:cl-ppcre
-               :alexandria
-               #+(or)
-               (:require :sb-cover))
+               :alexandria)
   :serial t
   :in-order-to ((test-op (test-op :data-lens/test)))
   :components ((:file "package")
@@ -23,8 +21,7 @@
   :license "Apache v2"
   :depends-on (:data-lens
                :fiveam
-               :string-case
-               :serapeum)
+               :string-case)
   :serial t
   :perform (test-op (o c)
                     (unless (symbol-call :fiveam '#:run! :data-lens.lens)
@@ -38,8 +35,7 @@
   :author "Edward Langley <el-cl@elangley.org>"
   :license "Apache v2"
   :depends-on (:data-lens
-               :alexandria
-               :serapeum)
+               :alexandria)
   :serial t
   :in-order-to ((test-op (test-op :data-lens/transducers/test)))
   :components ((:file "package")

lazy-sequence.lisp

@@ -29,6 +29,11 @@
        (lambda ()
          v))))
 
+(defun unsplice (form)
+  (if form
+      (list form)
+      nil))
+
 (defun iota (&key (start 0) (step 1) count)
   (lazy-sequence
    (funcall
@@ -36,14 +41,14 @@
              `(lambda ()
                 (declare (optimize (speed 3) (debug 1) (safety 1)))
                 (let ((init ,start)
-                      ,@(serapeum:unsplice (when count
+                      ,@(unsplice (when count
                                     '(iterations 0))))
                   (declare (type (integer ,start
                                           ,(if count
                                                (+ start (* count step))
                                                '*))
                                  init)
-                           ,@(serapeum:unsplice
+                           ,@(unsplice
                               (when count
                                 `(type (integer 0 ,count) iterations))))
                   (lambda ()
@@ -53,6 +58,6 @@
                            '(progn))
                      (prog1 init
                        (incf init ,step)
-                       ,@(serapeum:unsplice
+                       ,@(unsplice
                           (when count
                             '(incf iterations))))))))))))

optics.lisp

@@ -217,3 +217,19 @@ contain the new value at the location focused by the lens."
               (set 'a-lens 2
                    (make-instance 'foo :a 1)))) #|
   ==> 3 |#)
+
+(defgeneric generic-lens (rec cb loc)
+  (:method ((rec hash-table) cb loc)
+    (funcall (funcall (make-hash-table-lens loc)
+                      cb)
+             rec))
+ (:method ((rec vector) cb loc)
+    (funcall (funcall (make-list-lens loc)
+                      cb)
+             rec)))
+
+(defun lens (loc)
+  "extensible lens using a multimethod for internal implementation"
+  (lambda (cb)
+    (lambda (rec)
+      (generic-lens rec cb loc))))

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))

t/lens.lisp

@@ -183,9 +183,19 @@
                                              (acons "c" (make-instance 'my-map) ())
                                              :test 'equal))))))))
 
+(defun eqq (a b)
+  (typecase a
+    (string (equal a b))
+    (vector (and (vectorp b)
+                 (= (length a) (length b))
+                 (every 'eqq a b)))
+    (cons (and (consp b)
+               (eqq (car a) (car b))
+               (eqq (cdr a) (cdr b))))
+    (t (eql a b))))
+
 (5am:def-test regex-match (:suite :data-lens.lens)
-  (5am:is (serapeum:seq=
-           (list "acb" #("c"))
+  (5am:is (eqq (list "acb" #("c"))
                (multiple-value-list
                 (funcall (data-lens:regex-match "a(.)b")
                          "<acb>")))))

t/transducers.lisp

@@ -182,7 +182,8 @@
                   (data-lens.transducers:catting)
                   (data-lens.transducers:mapping #'parse-integer)
                   (data-lens.transducers:filtering (complement #'evenp))
-                  (data-lens.transducers:splitting (serapeum:op (* 2 _)) #'identity)
+                  (data-lens.transducers:splitting (lambda (_) (* 2 _))
+                                                   #'identity)
                   (data-lens.transducers:mapping (data-lens:transform-head #'1+))
                   (data-lens.transducers:taking 3))
                  'data-lens.transducers:hash-table-builder
@@ -236,6 +237,22 @@
                          '<
                          :key 'car))))
 
+  (5am:is (equalp #(1 2 3 4)
+                  (data-lens.transducers:into #() '(1 2 3 4)))
+          "~s can be used to convert one type into another without a transducer"
+          'data-lens.transducers:into)
+
+  (5am:is (equalp #(1 2 4)
+                  (handler-bind ((simple-error #'continue))
+                    (data-lens.transducers:into #()
+                                                (data-lens.transducers:mapping
+                                                 (lambda (it)
+                                                   (if (= it 3)
+                                                       (error "fail")
+                                                       it)))
+                                                '(1 2 3 4))))
+          "transducers provide a continue restart")
+
   (loop for type in '(vector list)
         do (5am:is (equalp #(1 2 3 4 5 6)
                            (data-lens.transducers:into #(1 2 3)

transducer-protocol.lisp

@@ -16,22 +16,50 @@
                seq)
       acc)))
 
-#+(or)
-(defun document (&rest strings)
-  (serapeum:string-join strings #.(format nil "~2%")))
+(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 init (client)
+  (:method ((client symbol))
+    (unless (fboundp client)
+      (error "client not funcallable"))
+    (init (fdefinition client)))
+  (:method ((client function))
+    (funcall client)))
+
+(defgeneric stepper (client)
+  (:method ((client function))
+    (transducer-lambda
+      ((acc a)
+       (declare (optimize (speed 3)))
+       (funcall client acc a))))
+  (:method ((client symbol))
+    (unless (fboundp client)
+      (error "client not funcallable"))
+    (init (fdefinition client))))
 
-(defgeneric init (client))
-(defgeneric stepper (client))
 (defgeneric unwrap (client obj)
   (:method (client obj) obj))
+
 (defgeneric builder-for-input (seq)
   (:documentation
    "Take a transducible sequence, return a builder and an init value for that builder.
 
 CONSTRAINT: SEQ should be copied, not modified"))
 
+(declaim (inline exit-early))
 (defun exit-early (acc)
   (throw 'done acc))
+(declaim (notinline exit-early))
 
 (defun transduce (xf build seq)
   (let* ((xf (etypecase xf
@@ -45,7 +73,16 @@ CONSTRAINT: SEQ should be copied, not modified"))
                                        transducer
                                        (init build)))))))
 
-(defun into (to xf from)
+(defun into (to xf &optional (from nil from-p))
+  (if (not from-p)
+      (let ((from xf))
+        (data-lens.transducers:into to
+                                    (data-lens.transducers:mapping
+                                     (lambda (&rest args)
+                                       (if (null (cdr args))
+                                           (car args)
+                                           args)))
+                                    from))
   (multiple-value-bind (builder init) (builder-for-input to)
     (let* ((xf (etypecase xf
                  (list (apply 'alexandria:compose xf))
@@ -56,7 +93,7 @@ CONSTRAINT: SEQ should be copied, not modified"))
                        (catch 'done
                          (reduce-generic from
                                          transducer
-                                         init)))))))
+                                             init))))))))
 
 (defmacro defdocumentation (name &body doc-specs)
   name doc-specs

transducers.lisp

@@ -23,7 +23,12 @@
     (lambda (rf)
       (transducer-lambda
         ((acc next)
-         (funcall rf acc (call-function next)))
+         (restart-case
+             (funcall rf acc (call-function next))
+           (continue ()
+             :report (lambda (s)
+                       (format s "skip this item"))
+             acc)))
         ((it) (funcall rf it))))))
 
 (defun mv-mapping (function &rest args)