103 lines
2.2 KiB
Scheme
103 lines
2.2 KiB
Scheme
(define-module (d-)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (language tree-il)
|
|
#:export
|
|
(~>
|
|
~>>
|
|
as~>
|
|
if-not
|
|
when-not
|
|
if-let
|
|
for
|
|
partial
|
|
argmin
|
|
iterate
|
|
upply
|
|
generator
|
|
macro-expand))
|
|
|
|
(define-syntax ~>
|
|
(syntax-rules ()
|
|
[(~> v) v]
|
|
[(~> v (fn args ...) more ...) (~> (fn v args ...) more ...)]
|
|
[(~> v fn more ...) (~> (fn v) more ...)]))
|
|
|
|
(define-syntax ~>>
|
|
(syntax-rules ()
|
|
[(~>> v) v]
|
|
[(~>> v (fn args ...) more ...) (~>> (fn args ... v) more ...)]
|
|
[(~>> v fn more ...) (~>> (fn v) more ...)]))
|
|
|
|
(define-syntax as~>
|
|
(syntax-rules ()
|
|
[(_ as v) v]
|
|
[(_ as v (fn args ...) more ...)
|
|
(let [(as v)]
|
|
(as~> as (fn args ...) more ...))]))
|
|
|
|
(define-syntax-rule (if-not pred body ...)
|
|
(if (not pred) body ...))
|
|
|
|
(define-syntax-rule (when-not pred body ...)
|
|
(when (not pred) body ...))
|
|
|
|
(define-syntax-rule (if-let ([ident test]) expr ...)
|
|
(let ([ident test])
|
|
(if ident
|
|
(begin expr ...)
|
|
#f)))
|
|
|
|
(define-syntax for
|
|
(syntax-rules ()
|
|
[(for () expr ...) (list (begin expr ...))]
|
|
[(for ([ident lst] bindings ...) expr ...)
|
|
(let iter ([rest lst])
|
|
(if (pair? rest)
|
|
(let ([ident (car rest)])
|
|
(append (for (bindings ...) expr ...) (iter (cdr rest))))
|
|
'()))]))
|
|
|
|
(define (partial fn . args)
|
|
(lambda x (apply fn (append args x))))
|
|
|
|
(define (argmin arg lt? . vals)
|
|
(reduce (lambda (val min)
|
|
(if (lt? (arg val) (arg min))
|
|
val
|
|
min))
|
|
#f
|
|
vals))
|
|
|
|
(define (iterate n f v)
|
|
(if (zero? n)
|
|
v
|
|
(iterate (1- n) f (f v))))
|
|
|
|
(define (upply a b cmp . fs)
|
|
(let ([arm-f (apply compose fs)])
|
|
(cmp (arm-f a) (arm-f b))))
|
|
|
|
;; Shamelessly ripped from https://wingolog.org/archives/2013/02/25/on-generators
|
|
(define (make-generator f)
|
|
(define tag (make-prompt-tag))
|
|
(define (thunk)
|
|
(f (lambda (val) (abort-to-prompt tag val))))
|
|
(lambda ()
|
|
(call-with-prompt tag
|
|
thunk
|
|
(lambda (k value)
|
|
(set! thunk k)
|
|
value))))
|
|
|
|
(define-syntax generator
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
[(generator expr ...)
|
|
(with-syntax ([yield (datum->syntax x 'yield)])
|
|
#'(make-generator
|
|
(lambda (yield)
|
|
expr ...)))])))
|
|
|
|
;; Why wasn't this included?
|
|
(define macro-expand (compose tree-il->scheme macroexpand))
|