std/injest: smart thread-last with transducer fusion
ober
76adee92568b231ca324a161239b8b7f2927c04d
new file mode 100644 --- /dev/null +++ b/lib/std/injest.sls @@ -0,0 +1,167 @@ +#!chezscheme +;;; (std injest) — Clojure-style injest smart threading macros. +;;; +;;; Inspired by matthewdowney/injest for Clojure. Provides two macros: +;;; +;;; (=> coll step ...) — smart thread-last (like ->>) with automatic +;;; transducer fusion when two or more adjacent +;;; steps are recognised sequence operations. +;;; +;;; (x>> coll step ...) — explicit transducer pipeline. Every step +;;; must be a recognised transducer-convertible +;;; form; expansion produces a single fused +;;; (sequence (compose-transducers ...) coll) +;;; call. Use when you want to guarantee fusion +;;; and get a compile-time error otherwise. +;;; +;;; Recognised heads (each maps to an (std transducer) constructor): +;;; +;;; (map f) -> (mapping f) +;;; (filter p) -> (filtering p) +;;; (remove p) -> (filtering (lambda (x) (not (p x)))) +;;; (take n) -> (taking n) +;;; (drop n) -> (dropping n) +;;; (mapcat f) -> (flat-mapping f) +;;; (append-map f) -> (flat-mapping f) +;;; (take-while p) -> (taking-while p) +;;; (drop-while p) -> (dropping-while p) +;;; (filter-map f) -> (mapping f) + (filtering identity) +;;; (dedupe) -> (deduplicate) ; consecutive-only +;;; (deduplicate) -> (deduplicate) +;;; (indexing) -> (indexing) +;;; (enumerate) -> (indexing) +;;; (indexed) -> (indexing) +;;; +;;; Head matching is by symbol name (not free-identifier=?), so the +;;; macros recognise these operations regardless of which import they +;;; came from. Steps not matching a recognised head fall through to +;;; plain thread-last semantics in =>, and are a syntax error in x>>. +;;; +;;; A single recognised step in => is emitted as the native call +;;; (e.g. (map f v)) rather than through the transducer machinery, to +;;; avoid the allocation overhead of a one-stage pipeline. Fusion only +;;; kicks in when a run has two or more recognised steps. + +(library (std injest) + (export => x>>) + (import (except (chezscheme) =>) + (std transducer)) + + ;; --------------------------------------------------------------- + ;; Head recognition (compile-time helpers). + ;; --------------------------------------------------------------- + ;; Return a syntax object for the transducer constructor expression, + ;; or #f if step is not a recognised transducer-convertible form. + + (meta define (recognize-step step) + (syntax-case step () + [(head arg ...) + (identifier? #'head) + (case (syntax->datum #'head) + [(map) #'(mapping arg ...)] + [(filter) #'(filtering arg ...)] + [(remove) + (syntax-case #'(arg ...) () + [(p) #'(filtering (lambda (%x) (not (p %x))))] + [_ #f])] + [(take) #'(taking arg ...)] + [(drop) #'(dropping arg ...)] + [(mapcat append-map) #'(flat-mapping arg ...)] + [(take-while) #'(taking-while arg ...)] + [(drop-while) #'(dropping-while arg ...)] + [(filter-map) + (syntax-case #'(arg ...) () + [(f) #'(compose-transducers + (mapping f) + (filtering (lambda (%x) %x)))] + [_ #f])] + [(dedupe deduplicate) #'(deduplicate)] + [(indexing enumerate indexed) #'(indexing)] + [else #f])] + [head + (identifier? #'head) + (case (syntax->datum #'head) + [(dedupe deduplicate) #'(deduplicate)] + [(indexing enumerate indexed) #'(indexing)] + [else #f])] + [_ #f])) + + ;; Build the syntax for a plain thread-last application of step to v. + ;; (f a b) , v => (f a b v) + ;; f , v => (f v) + (meta define (thread-last-apply step v) + (syntax-case step () + [(f arg ...) (with-syntax ([v v]) #'(f arg ... v))] + [f (with-syntax ([v v]) #'(f v))])) + + ;; Given a non-empty list of ORIGINAL step syntaxes that were all + ;; recognised, and the input value syntax v, return the expression + ;; syntax for running them. A singleton run is emitted as the native + ;; call (no transducer overhead); a longer run is fused. + (meta define (emit-run v run) + (cond + [(null? (cdr run)) + ;; Single recognised step — emit as native thread-last call. + (thread-last-apply (car run) v)] + [else + (let ([xfs (map recognize-step run)]) + (with-syntax ([(xf ...) xfs] + [v v]) + #'(sequence (compose-transducers xf ...) v)))])) + + ;; Main walk: fold a list of steps into a nested expression over v. + (meta define (walk v steps) + (cond + [(null? steps) v] + [(recognize-step (car steps)) + ;; Start a run; greedily extend while next steps are recognised. + (let loop ([run (list (car steps))] + [rest (cdr steps)]) + (cond + [(null? rest) + (emit-run v (reverse run))] + [(recognize-step (car rest)) + (loop (cons (car rest) run) (cdr rest))] + [else + (walk (emit-run v (reverse run)) rest)]))] + [else + (walk (thread-last-apply (car steps) v) (cdr steps))])) + + ;; --------------------------------------------------------------- + ;; => : smart thread-last + ;; --------------------------------------------------------------- + (define-syntax => + (lambda (stx) + (syntax-case stx () + [(_ v) #'v] + [(_ v step ...) + (walk #'v (syntax->list #'(step ...)))]))) + + ;; --------------------------------------------------------------- + ;; x>> : strict transducer pipeline + ;; --------------------------------------------------------------- + (define-syntax x>> + (lambda (stx) + (syntax-case stx () + [(_ v) #'v] + [(_ v step ...) + (let* ([steps (syntax->list #'(step ...))] + [xfs (map recognize-step steps)] + [bad (let loop ([ss steps] [rs xfs]) + (cond + [(null? ss) #f] + [(not (car rs)) (car ss)] + [else (loop (cdr ss) (cdr rs))]))]) + (cond + [bad + (syntax-violation 'x>> + "step is not a recognised transducer-convertible form" + stx bad)] + [(null? (cdr xfs)) + (with-syntax ([xf (car xfs)]) + #'(sequence xf v))] + [else + (with-syntax ([(xf ...) xfs]) + #'(sequence (compose-transducers xf ...) v))]))]))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-injest.ss @@ -0,0 +1,181 @@ +#!chezscheme +;;; Tests for (std injest) — smart threading macros with auto-fusion. + +(import (except (chezscheme) =>) (std injest) (std transducer)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s, expected ~s~%" name got expected)))))])) + +(printf "--- (std injest) tests ---~%") + +;;;; => : identity / single step + +(test "=> identity" + (=> '(1 2 3)) + '(1 2 3)) + +(test "=> single recognised step (map)" + (=> '(1 2 3) (map (lambda (x) (* x 2)))) + '(2 4 6)) + +(test "=> single recognised step (filter)" + (=> '(1 2 3 4 5) (filter even?)) + '(2 4)) + +(test "=> single unrecognised step" + (=> '(1 2 3) reverse) + '(3 2 1)) + +(test "=> non-recognised with args" + (=> '(1 2 3 4) (append '(0))) + '(0 1 2 3 4)) + +;;;; => : fused runs + +(test "=> fused map+filter" + (=> '(1 2 3 4 5) + (map (lambda (x) (* x x))) + (filter even?)) + '(4 16)) + +(test "=> fused map+filter+take" + (=> '(1 2 3 4 5 6 7 8 9 10) + (map (lambda (x) (+ x 1))) + (filter odd?) + (take 3)) + '(3 5 7)) + +(test "=> filter+remove" + (=> '(1 2 3 4 5 6) + (filter (lambda (x) (> x 1))) + (remove (lambda (x) (= x 4)))) + '(2 3 5 6)) + +(test "=> take-while+drop-while" + (=> '(1 2 3 10 20 3 4 5) + (take-while (lambda (x) (< x 15))) + (drop-while (lambda (x) (< x 5)))) + '(10)) + +(test "=> mapcat flattens" + (=> '(1 2 3) + (mapcat (lambda (x) (list x x))) + (take 4)) + '(1 1 2 2)) + +;;;; => : fused run followed by non-recognised step + +(test "=> fused run then reverse" + (=> '(1 2 3 4 5) + (map (lambda (x) (* x 10))) + (filter (lambda (x) (> x 20))) + reverse) + '(50 40 30)) + +(test "=> non-recognised then fused run" + (=> '((3 4) (1 2) (5 6)) + reverse + (mapcat (lambda (p) p)) + (filter odd?)) + '(5 1 3)) + +(test "=> two fused runs split by plain step" + (=> '(1 2 3 4 5) + (map (lambda (x) (* x x))) ;; run 1: fused + (filter (lambda (x) (> x 1))) + reverse ;; plain + (map (lambda (x) (+ x 100))) ;; run 2: single native + ) + '(125 116 109 104)) + +;;;; => : vector / string inputs (transducer supports them) + +(test "=> over vector, fused" + (=> (vector 1 2 3 4 5) + (map (lambda (x) (* x 3))) + (filter (lambda (x) (> x 6)))) + '(9 12 15)) + +;;;; => : argless recognised forms + +(test "=> deduplicate consecutive" + (=> '(1 1 2 2 2 3 1 1) + (dedupe) + (map (lambda (x) (* x 10)))) + '(10 20 30 10)) + +;;;; x>> : basic pipelines + +(test "x>> single step" + (x>> '(1 2 3) (map (lambda (x) (+ x 1)))) + '(2 3 4)) + +(test "x>> fused 3-step" + (x>> '(1 2 3 4 5 6 7 8) + (filter even?) + (map (lambda (x) (* x x))) + (take 2)) + '(4 16)) + +(test "x>> mapcat+take" + (x>> '(1 2 3 4) + (mapcat (lambda (x) (list x (- x)))) + (take 5)) + '(1 -1 2 -2 3)) + +(test "x>> filter-map" + (x>> '(1 2 3 4 5) + (filter-map (lambda (x) (and (even? x) (* x 10))))) + '(20 40)) + +;;;; Edge case: empty collection + +(test "=> empty list fused" + (=> '() + (map (lambda (x) x)) + (filter odd?)) + '()) + +;;;; Edge case: single elt, run of 3 + +(test "=> single elt 3-stage" + (=> '(42) + (map (lambda (x) (+ x 1))) + (filter (lambda (_) #t)) + (take 10)) + '(43)) + +;;;; Ensure semantics match plain ->> + +(test "=> matches ->> semantics (plain steps only)" + (let ([plain (reverse (cdr '(0 1 2 3 4 5)))]) + (equal? plain (=> '(0 1 2 3 4 5) cdr reverse))) + #t) + +;;;; Ensure short-circuit via (take) in fused run + +(define counter 0) + +(test "=> (take) short-circuits fused pipeline" + (begin + (set! counter 0) + (let ([r (=> '(1 2 3 4 5 6 7 8 9 10) + (map (lambda (x) (set! counter (+ counter 1)) x)) + (take 3))]) + (list r counter))) + '((1 2 3) 3)) + +(printf "~%~a passed, ~a failed~%" pass fail) +(exit (if (zero? fail) 0 1))