initial
This commit is contained in:
commit
e2b077766e
2 changed files with 361 additions and 0 deletions
223
match.sls
Normal file
223
match.sls
Normal file
|
|
@ -0,0 +1,223 @@
|
||||||
|
;; extensible, syntax property-based matching for chez scheme a la trivia
|
||||||
|
(library (meh match)
|
||||||
|
(export
|
||||||
|
match if-let when-let
|
||||||
|
define-m%-expander define-pattern define-pattern-expander
|
||||||
|
m%-expander pattern-expander
|
||||||
|
|
||||||
|
; built-in patterns
|
||||||
|
fail and or not guard
|
||||||
|
access satisfies cons
|
||||||
|
list list*
|
||||||
|
vector vector*
|
||||||
|
= < > <= >=
|
||||||
|
quote quasiquote
|
||||||
|
)
|
||||||
|
(import (chezscheme))
|
||||||
|
|
||||||
|
|
||||||
|
;; binding the scrutinee once makes the expanded code nicer to read
|
||||||
|
(define-syntax match
|
||||||
|
(syntax-rules ()
|
||||||
|
[(match scrutinee clause* ...)
|
||||||
|
(let ([s scrutinee])
|
||||||
|
(match% s clause* ...))]))
|
||||||
|
|
||||||
|
;; i just like rust's thing too much
|
||||||
|
(define-syntax if-let
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ pattern scrutinee then) (if-let pattern scrutinee then (void))]
|
||||||
|
[(_ pattern scrutinee then else)
|
||||||
|
(match scrutinee
|
||||||
|
[pattern then]
|
||||||
|
[_ else])]))
|
||||||
|
|
||||||
|
(define-syntax when-let
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ pattern scrutinee body* ...)
|
||||||
|
(if-let pattern scrutinee (begin body* ...))]))
|
||||||
|
|
||||||
|
;; no unless-let because come on
|
||||||
|
|
||||||
|
(define-syntax match%
|
||||||
|
(syntax-rules ()
|
||||||
|
[(match% scrutinee) (void)]
|
||||||
|
[(match% scrutinee [pattern body* ...] clause* ...)
|
||||||
|
(m% scrutinee pattern
|
||||||
|
(begin body* ...)
|
||||||
|
(match% scrutinee clause* ...))]))
|
||||||
|
|
||||||
|
(define m%-expander)
|
||||||
|
(define pattern-expander)
|
||||||
|
|
||||||
|
(define-syntax m%
|
||||||
|
(lambda (e)
|
||||||
|
(lambda (lookup)
|
||||||
|
(define (find-m%-expander name)
|
||||||
|
(and (identifier? name) (lookup name #'m%-expander)))
|
||||||
|
(define (find-pattern-expander name)
|
||||||
|
(and (identifier? name) (lookup name #'pattern-expander)))
|
||||||
|
;; - is a decent choice because _ isn't allowed and * implies something else
|
||||||
|
(syntax-case e (-)
|
||||||
|
[(_ s - ok fail) #'ok]
|
||||||
|
|
||||||
|
[(_ s pat ok fail) (identifier? #'pat)
|
||||||
|
#'(let ([pat s]) ok)]
|
||||||
|
|
||||||
|
;; before atom? because vectors are (rightly) atoms
|
||||||
|
[(_ s #(pat* ...) ok fail)
|
||||||
|
#'(m% s (vector pat* ...) ok fail)]
|
||||||
|
|
||||||
|
[(_ s pat ok fail) (atom? (syntax->datum #'pat))
|
||||||
|
#'(if (equal? s pat) ok fail)]
|
||||||
|
|
||||||
|
[(_ s (patf pata* ...) ok fail) (find-m%-expander #'patf)
|
||||||
|
((find-m%-expander #'patf) #'(patf s ok fail pata* ...))]
|
||||||
|
|
||||||
|
[(_ s (patf pata* ...) ok fail) (find-pattern-expander #'patf)
|
||||||
|
#`(m% s #,((find-pattern-expander #'patf) #'(patf pata* ...))
|
||||||
|
ok fail)]
|
||||||
|
|
||||||
|
[(e s (patf pata* ...) ok fail)
|
||||||
|
#`(syntax-violation
|
||||||
|
'm%
|
||||||
|
#,(format "no m%-expander or pattern-expander for ~a"
|
||||||
|
(syntax->datum #'patf))
|
||||||
|
#'(e s (patf pata* ...) ok fail)
|
||||||
|
#'(patf pata* ...))]))))
|
||||||
|
|
||||||
|
;; TODO: define-m% consistent with define-pattern
|
||||||
|
(define-syntax define-m%-expander
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ name [(arg* ...) out] ...)
|
||||||
|
(define-property name m%-expander
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ arg* ...) out] ...))]))
|
||||||
|
|
||||||
|
;; sufficient for most uses
|
||||||
|
(define-syntax define-pattern
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ (name arg* ...) out)
|
||||||
|
(define-pattern name
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ arg* ...) out]))]
|
||||||
|
[(_ name body body* ...)
|
||||||
|
(define-property name pattern-expander
|
||||||
|
(begin body body* ...))]))
|
||||||
|
|
||||||
|
(define-syntax define-pattern-expander
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ name [(arg* ...) out] ...)
|
||||||
|
(define-pattern name
|
||||||
|
(syntax-rules ()
|
||||||
|
[(_ arg* ...) out] ...))]))
|
||||||
|
|
||||||
|
(define fail)
|
||||||
|
(define-m%-expander fail
|
||||||
|
[(s ok fail) fail])
|
||||||
|
|
||||||
|
(define-m%-expander and
|
||||||
|
[(s ok fail) ok]
|
||||||
|
[(s ok fail pat) (m% s pat ok fail)]
|
||||||
|
[(s ok fail pat pat* ...)
|
||||||
|
(m% s pat
|
||||||
|
(m% s (and pat* ...)
|
||||||
|
ok fail)
|
||||||
|
fail)])
|
||||||
|
|
||||||
|
(define-m%-expander or
|
||||||
|
[(s ok fail) fail]
|
||||||
|
[(s ok fail pat) (m% s pat ok fail)]
|
||||||
|
[(s ok fail pat pat* ...)
|
||||||
|
(m% s pat
|
||||||
|
ok
|
||||||
|
(m% s (or pat* ...)
|
||||||
|
ok fail))])
|
||||||
|
|
||||||
|
(define-m%-expander not
|
||||||
|
[(s ok fail pat) (m% s pat fail ok)])
|
||||||
|
|
||||||
|
(define-m%-expander guard
|
||||||
|
[(s ok fail subpat win?)
|
||||||
|
(m% s subpat
|
||||||
|
(if win?
|
||||||
|
ok
|
||||||
|
fail)
|
||||||
|
fail)])
|
||||||
|
|
||||||
|
(define access)
|
||||||
|
(define-m%-expander access
|
||||||
|
[(s ok fail fun pat)
|
||||||
|
(m% (fun s) pat
|
||||||
|
ok fail)])
|
||||||
|
|
||||||
|
;; intermediate vars here are very unnecessary but they get optimized out extremely easily
|
||||||
|
(define-pattern (quote val)
|
||||||
|
(guard x (equal? x 'val)))
|
||||||
|
|
||||||
|
(define satisfies)
|
||||||
|
(define-pattern (satisfies pred?)
|
||||||
|
(guard x (pred? x)))
|
||||||
|
|
||||||
|
(define-pattern (cons a d)
|
||||||
|
(and (satisfies pair?)
|
||||||
|
(access car a)
|
||||||
|
(access cdr d)))
|
||||||
|
|
||||||
|
(define-pattern-expander list
|
||||||
|
[() '()]
|
||||||
|
[(x x* ...) (cons x (list x* ...))])
|
||||||
|
|
||||||
|
(define-pattern-expander list*
|
||||||
|
[() '()]
|
||||||
|
[(x) x]
|
||||||
|
[(x x* ...) (cons x (list* x* ...))])
|
||||||
|
|
||||||
|
(define-property vector pattern-expander
|
||||||
|
(lambda (e)
|
||||||
|
(syntax-case e ()
|
||||||
|
[(_) #'(and (satisfies vector?) (guard x (zero? (vector-length x))))]
|
||||||
|
[(_ x* ...)
|
||||||
|
(let* ([pats (syntax->list #'(x* ...))]
|
||||||
|
[len (length pats)])
|
||||||
|
#`(and (satisfies vector?)
|
||||||
|
(guard x (= #,len (vector-length x)))
|
||||||
|
#,@(map
|
||||||
|
(lambda (i p) #`(access (lambda (s) (vector-ref s #,i)) #,p))
|
||||||
|
(iota (length pats))
|
||||||
|
pats)))])))
|
||||||
|
|
||||||
|
(define vector*)
|
||||||
|
(define-property vector* pattern-expander
|
||||||
|
(lambda (e)
|
||||||
|
(syntax-case e ()
|
||||||
|
[(_) #'(and (satisfies vector?) (guard x (zero? (vector-length x))))]
|
||||||
|
[(_ x* ...)
|
||||||
|
(let* ([pats (syntax->list #'(x* ...))]
|
||||||
|
[len (length pats)])
|
||||||
|
#`(and (satisfies vector?)
|
||||||
|
;; v only difference
|
||||||
|
(guard x (<= #,len (vector-length x)))
|
||||||
|
#,@(map
|
||||||
|
(lambda (i p) #`(access (lambda (s) (vector-ref s #,i)) #,p))
|
||||||
|
(iota (length pats))
|
||||||
|
pats)))])))
|
||||||
|
|
||||||
|
;; no !=
|
||||||
|
;; you can already do (satisfies (partial = n))
|
||||||
|
(define-pattern (= n) (and (satisfies number?) (guard x (= n x))))
|
||||||
|
|
||||||
|
(define-pattern (< n) (and (satisfies real?) (guard x (< x n))))
|
||||||
|
(define-pattern (> n) (and (satisfies real?) (guard x (> x n))))
|
||||||
|
(define-pattern (<= n) (and (satisfies real?) (guard x (<= x n))))
|
||||||
|
(define-pattern (>= n) (and (satisfies real?) (guard x (>= x n))))
|
||||||
|
|
||||||
|
;; ,@ is not likely to happen
|
||||||
|
(define-pattern quasiquote
|
||||||
|
(syntax-rules (unquote)
|
||||||
|
[(_ (unquote pat)) pat]
|
||||||
|
;; this specialization *probably* has no perf benefit
|
||||||
|
[(_ (x* ...)) (list `x* ...)]
|
||||||
|
[(_ (a . d)) (cons `a `d)]
|
||||||
|
[(_ x) 'x]))
|
||||||
|
)
|
||||||
138
std.sls
Normal file
138
std.sls
Normal file
|
|
@ -0,0 +1,138 @@
|
||||||
|
;; amalgam of useful stuff
|
||||||
|
(library (meh std)
|
||||||
|
(export
|
||||||
|
let1 -> ->> as->
|
||||||
|
|
||||||
|
define-syntax-rule
|
||||||
|
|
||||||
|
λ
|
||||||
|
|
||||||
|
let/cc let/1cc
|
||||||
|
|
||||||
|
identity const const*
|
||||||
|
thunk thunk*
|
||||||
|
compose compose1 partial
|
||||||
|
negate conjoin disjoin)
|
||||||
|
|
||||||
|
(import (chezscheme))
|
||||||
|
|
||||||
|
(export (import (meh match)))
|
||||||
|
|
||||||
|
;;; SYNTAX
|
||||||
|
|
||||||
|
(define-syntax let1
|
||||||
|
(lambda (e)
|
||||||
|
(syntax-case e ()
|
||||||
|
[(let1 name val body ...) (identifier? #'name)
|
||||||
|
#'(let ([name val])
|
||||||
|
body ...)])))
|
||||||
|
|
||||||
|
;; i H8TE that (-> x (partial + 1)) is (partial x + 1)
|
||||||
|
;; maybe there should be a proc version
|
||||||
|
(define-syntax ->
|
||||||
|
(syntax-rules ()
|
||||||
|
[(-> x) x]
|
||||||
|
[(-> x (f x* ...) f* ...)
|
||||||
|
(-> (f x x* ...) f* ...)]
|
||||||
|
[(-> x f f* ...)
|
||||||
|
(-> (f x) f* ...)]))
|
||||||
|
|
||||||
|
(define-syntax ->>
|
||||||
|
(syntax-rules ()
|
||||||
|
[(->> x) x]
|
||||||
|
[(->> x (f x* ...) f* ...)
|
||||||
|
(->> (f x* ... x) f* ...)]
|
||||||
|
[(->> x f f* ...)
|
||||||
|
(->> (f x) f* ...)]))
|
||||||
|
|
||||||
|
;; iirc, the clojure as-> puts the expression in place (i.e. no binding)
|
||||||
|
(define-syntax as->
|
||||||
|
(lambda (e)
|
||||||
|
(syntax-case e ()
|
||||||
|
[(as-> name x) (identifier? #'name) #'x]
|
||||||
|
[(as-> name x (f x* ...) f* ...) (identifier? #'name)
|
||||||
|
#'(let* ([name x]
|
||||||
|
[name (f x* ...)])
|
||||||
|
(as-> name name f* ...))]
|
||||||
|
[(as-> name x f f* ...) (identifier? #'name)
|
||||||
|
#'(as-> name x (f name) f* ...)])))
|
||||||
|
|
||||||
|
;; straight from racket; canonical
|
||||||
|
(define-syntax define-syntax-rule
|
||||||
|
(syntax-rules ()
|
||||||
|
[(define-syntax-rule (id . pattern) templ)
|
||||||
|
(define-syntax id
|
||||||
|
(syntax-rules ()
|
||||||
|
[(id . pattern) templ]))]))
|
||||||
|
|
||||||
|
(alias λ lambda)
|
||||||
|
|
||||||
|
;;; CONTINUATIONS
|
||||||
|
(define-syntax-rule (let/cc name body* ...) (call/cc (lambda (name) body* ...)))
|
||||||
|
(define-syntax-rule (let/1cc name body* ...) (call/1cc (lambda (name) body* ...)))
|
||||||
|
|
||||||
|
;;; PROCEDURE MANIP
|
||||||
|
|
||||||
|
;; could just be values, but this is a pinch better
|
||||||
|
(define (identity x) x)
|
||||||
|
|
||||||
|
(define (const x) (rec const-fn (lambda _ x)))
|
||||||
|
(define (const* . xs) (rec const*-fn (lambda _ (apply values xs))))
|
||||||
|
|
||||||
|
(define-syntax-rule (thunk body ...) (lambda () body ...))
|
||||||
|
(define-syntax-rule (thunk* body ...) (lambda _ body ...))
|
||||||
|
|
||||||
|
;; ((compose f g h) x) = (f (g (h x)))
|
||||||
|
(define (compose . fs)
|
||||||
|
(if (null? fs)
|
||||||
|
values
|
||||||
|
(let ([f (car fs)]
|
||||||
|
[rest (apply compose (cdr fs))])
|
||||||
|
;; gives the procedure a better name
|
||||||
|
(rec compose-fn
|
||||||
|
(lambda xs
|
||||||
|
(call-with-values
|
||||||
|
(lambda () (apply rest xs))
|
||||||
|
f))))))
|
||||||
|
|
||||||
|
(define (compose1 . fs)
|
||||||
|
(if (null? fs)
|
||||||
|
identity
|
||||||
|
(let ([f (car fs)]
|
||||||
|
[rest (apply compose1 (cdr fs))])
|
||||||
|
(rec compose1-fn
|
||||||
|
(lambda (x)
|
||||||
|
(f (rest x)))))))
|
||||||
|
|
||||||
|
(define (partial f . xs)
|
||||||
|
(rec partial-fn
|
||||||
|
(lambda as
|
||||||
|
(apply f (append xs as)))))
|
||||||
|
|
||||||
|
;; maybe nouns would be preferable? eh why not be consistent with racket
|
||||||
|
(define (negate f)
|
||||||
|
(rec negate-fn (lambda xs (not (apply f xs)))))
|
||||||
|
|
||||||
|
(define conjoin
|
||||||
|
(case-lambda
|
||||||
|
[() (const #t)]
|
||||||
|
[(f) f]
|
||||||
|
[(f . fs)
|
||||||
|
(let ([rest (apply conjoin fs)])
|
||||||
|
(rec conjoin-fn
|
||||||
|
(lambda xs
|
||||||
|
(and (apply f xs) (apply rest xs)))))]))
|
||||||
|
|
||||||
|
;; could be (negate conjoin) but i like good proc names
|
||||||
|
(define disjoin
|
||||||
|
(case-lambda
|
||||||
|
[() (const #f)]
|
||||||
|
[(f) f]
|
||||||
|
[(f . fs)
|
||||||
|
(let ([rest (apply disjoin fs)])
|
||||||
|
(rec disjoin-fn
|
||||||
|
(lambda xs
|
||||||
|
(or (apply f xs) (apply rest xs)))))]))
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
Loading…
Reference in a new issue