-> ->> -<> -<>> for S7 Scheme

testarrows.scm

; -> ->> -<> -<>> for S7 Scheme
; inspired by https://github.com/nightfly19/cl-arrows and https://github.com/rplevy/swiss-arrows

(require stuff.scm)
; using: any? while
; replace those with your favorite scheme alternatives

; direct translation from https://github.com/nightfly19/cl-arrows
(define (arrow-proto handler initial-form forms)
  (let ((output-form initial-form)
        (remaining-forms forms))
    (while (pair? remaining-forms)
         (let ((current-form (car remaining-forms)))
           (if (pair? current-form)
                 (set! output-form (handler current-form output-form))
                 (set! output-form (list current-form output-form))))
         (set! remaining-forms (cdr remaining-forms)))
    output-form))

(define (arrow-handler-thread-first current-form output-form)
    (cons (car current-form) (cons output-form (cdr current-form))))

(define-macro (-> initial-form . forms) 
    (arrow-proto arrow-handler-thread-first initial-form forms))

(define (arrow-handler-thread-last current-form output-form)
    (cons (car current-form) (append (cdr current-form) (list output-form))))

(define-macro (->> initial-form . forms) 
    (arrow-proto arrow-handler-thread-last initial-form forms))

(define (arrow-has-diamond? haystack) (any? (lambda (e) (eq? e '<>)) haystack) )

(define (arrow-diamond-replace haystack output-form)
    (map (lambda (e) (if (eq? e '<>) output-form e)) haystack))

(define (arrow-handler-thread-diamond handler current-form output-form)
    (if (arrow-has-diamond? current-form)
        (arrow-diamond-replace current-form output-form)
        (handler current-form output-form)))

(define-macro (-<> initial-form . forms) 
    (arrow-proto (lambda (current-form output-form) (arrow-handler-thread-diamond arrow-handler-thread-first current-form output-form))
        initial-form forms))

(define-macro (-<>> initial-form . forms) 
    (arrow-proto (lambda (current-form output-form) (arrow-handler-thread-diamond arrow-handler-thread-last current-form output-form))
        initial-form forms))

(define c 5)

(display (-> c (- 3)) )
(display "\n")

; (display (-> c (+ 3) (/ 2) (- 1)) )
; (display "\n")

(display (->> c (- 3)) )
(display "\n")

(define (incr n) (+ n 1))
(display (-<> 4 (cons '(1 2 3)) reverse (map incr <>)) )