Skip to content

Instantly share code, notes, and snippets.

@monzee

monzee/example.scm

Last active May 27, 2020 07:11
Show Gist options
  • Save monzee/7e4a91de702a9e808a532bdfcd7bca8f to your computer and use it in GitHub Desktop.
Save monzee/7e4a91de702a9e808a532bdfcd7bca8f to your computer and use it in GitHub Desktop.
Download ZIP
Scheme section sequence macros (aka threading macros in clojure) with haskell-style 'where clause
Raw
example.scm
(define (hex->dec str)
(>> (string-fold add-next 0 str)
:where ; deferred declaration of local bindings
(char-values (map cons (string->list "0123456789abcdef") (iota 16)))
#((add-next digit acc) ; lambda binding shorthand in :where clause
(>> (assv-ref char-values digit)
(or (error "invalid hex digit" digit str))
(+ (* 16 acc))))))
(define (dec->hex num)
(>> "0123456789abcdef"
#(lambda (i) (string-ref _ i)) ; arbitrary section. binds the last value to '_
:as n->char ; rename the implicit var for the next arb section
#(let loop ((n num) (hex '()))
(if (< n 16)
(>> (n->char n) (cons hex) (list->string)) ; implicit var can be used many times anywhere
(loop (quotient n 16) ; in the form, even in the function position
(>> n (remainder 16) (n->char) (cons hex)))))))
(define (main args)
(>> :as % ; name the implicit var in all arb sections as '% unless overridden
args
#(if (and (pair? %) (pair? (cdr %)))
(cadr %)
(die "give me a hex string!"))
(string-downcase)
(hex->dec)
:do ; keep the current value after the next arb section returns
#(println %)
(dec->hex)
(println)
(false-if-exception)
(or (die "what you gave me probably isn't a hex string."))
:where
#((println it)
(display it)
(newline))
#((die msg)
(println msg)
(primitive-exit 1))))
Raw
section-dsl.scm
(define-syntax >>
(lambda (x)
(make-pipe x (lambda (inner outer args)
#`(#,outer #,inner . #,args)))))
(define-syntax <<
(lambda (x)
(make-pipe x (lambda (inner outer args)
#`(#,outer #,@args #,inner)))))
(define (make-pipe root wrap)
(define default-it (datum->syntax root '_))
(define (loop inner rest it peek)
(if (null? rest)
inner
(syntax-case rest (:where :as :do)
(((outer args ...) _ ...)
(loop (wrap inner #'outer #'(args ...))
(cdr rest)
it peek))
(((h . t) _ ...)
#'(syntax-error "invalid section; must be a proper list" (h . t)))
((:do _ ...)
(loop inner (cdr rest) it #t))
((:as symbol _ ...)
(identifier? #'symbol)
(loop inner (cddr rest) #'symbol peek))
((:as _ ...)
#'(syntax-error ":as must be followed by an identifier"))
((#(body body* ...) _ ...)
(loop #`(let ((#,it #,inner))
#,@(cons #'(body body* ...) (if peek (list it) '())))
(cdr rest)
default-it #f))
((:where bindings ...)
(where #'(bindings ...) inner))
(e #'(syntax-error
"invalid section; must be a list or a code vector"
e)))))
(syntax-case root (:as)
((_ :as symbol start next ...)
(identifier? #'symbol)
(begin
(set! default-it #'symbol)
(loop #'start #'(next ...) #'symbol #f)))
((_ :as _ ...)
#'(syntax-error ":as must be followed by an identifier"))
((_ start next ...)
(loop #'start #'(next ...) default-it #f))))
(define (where bindings e)
(syntax-case bindings ()
(() e)
(_ (let loop ((vars '()) (rest bindings))
(syntax-case rest ()
(((var val) _ ...)
(identifier? #'var)
(loop #`(#,@vars (var val))
(cdr rest)))
(((h . t) . _)
#'(syntax-error
"invalid binding; must be a 2-elem list and start with an identifier"
(h . t)))
((#((fun . args) body body* ...) _ ...)
(identifier? #'fun)
(loop #`(#,@vars (fun (lambda args body body* ...)))
(cdr rest)))
(()
#`(letrec #,vars #,e))
((e _ ...)
#'(syntax-error
"invalid form in :where clause; must be a binding or a shorthand named function"
e)))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment