Skip to content

Instantly share code, notes, and snippets.

@carloscm
Created April 7, 2015 21:49
Show Gist options
  • Save carloscm/66d517cca1e371115425 to your computer and use it in GitHub Desktop.
Save carloscm/66d517cca1e371115425 to your computer and use it in GitHub Desktop.
-> ->> -<> -<>> for S7 Scheme
; -> ->> -<> -<>> 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 <>)) )
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment