From e2b077766ee30c67384af8038a56042b2dd3e787 Mon Sep 17 00:00:00 2001
From: mehbark <terezi@pyrope.net>
Date: Sat, 22 Feb 2025 20:37:27 -0500
Subject: [PATCH] initial

---
 match.sls | 223 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 std.sls   | 138 +++++++++++++++++++++++++++++++++
 2 files changed, 361 insertions(+)
 create mode 100644 match.sls
 create mode 100644 std.sls

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)))))]))
+)
+
+