mirror of
https://github.com/fiddlerwoaroof/data-lens.git
synced 2025-11-08 10:16:32 +00:00
114 lines
3.9 KiB
Common Lisp
114 lines
3.9 KiB
Common Lisp
(in-package :data-lens.transducers.internals)
|
|
|
|
(defgeneric reduce-generic (seq func init)
|
|
(:method ((seq sequence) (func function) init)
|
|
(reduce func seq :initial-value init))
|
|
(:method ((seq sequence) (func symbol) init)
|
|
(reduce func seq :initial-value init))
|
|
(:method (seq (func symbol) init)
|
|
(reduce-generic seq
|
|
(symbol-function func)
|
|
init))
|
|
(:method ((seq hash-table) (func function) init)
|
|
(let ((acc init))
|
|
(maphash (lambda (k v)
|
|
(setf acc (funcall func acc (list k v))))
|
|
seq)
|
|
acc)))
|
|
|
|
(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 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
|
|
(list (apply 'alexandria:compose xf))
|
|
((or function symbol) xf)))
|
|
(transducer (funcall xf (stepper build))))
|
|
(unwrap build
|
|
(funcall transducer
|
|
(catch 'done
|
|
(reduce-generic seq
|
|
transducer
|
|
(init build)))))))
|
|
|
|
(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))
|
|
((or function symbol) xf)))
|
|
(transducer (funcall xf (stepper builder))))
|
|
(unwrap builder
|
|
(funcall transducer
|
|
(catch 'done
|
|
(reduce-generic from
|
|
transducer
|
|
init))))))))
|
|
|
|
(defmacro defdocumentation (name &body doc-specs)
|
|
name doc-specs
|
|
nil)
|
|
|
|
(defdocumentation transducer-protocol
|
|
(:function transduce (xf builder seq)
|
|
"Run a transducer XF over sequence SEQ using BUILDER to accumulate results.
|
|
|
|
Uses the generic function REDUCE-GENERIC so transducers work over lazy
|
|
sequences and hash tables.")
|
|
(:generic-function unwrap (client obj)
|
|
)
|
|
(:generic-function unwrap (client obj)
|
|
)
|
|
(:generic-function unwrap (client obj)
|
|
))
|