commit e2b077766ee30c67384af8038a56042b2dd3e787
Author: mehbark <terezi@pyrope.net>
Date: Sat Feb 22 20:37:27 2025 -0500
initial
diff --git a/match.sls b/match.sls
new file mode 100644
index 0000000..332470a
--- /dev/null
+++ b/match.sls
@@ -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]))
+ )
diff --git a/std.sls b/std.sls
new file mode 100644
index 0000000..bca7e57
--- /dev/null
+++ b/std.sls
@@ -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)))))]))
+)
+
+