Step 6 complete: Pattern Matching 2.0 (Steps 22-24)
ober
870eb1f02d6b5fcde9fc140f6812f6c9ebcff54e
--- a/Makefile +++ b/Makefile @@ -88,6 +88,7 @@ test-features: @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-iouring.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-stm.ss @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-ffi-bind.ss + @$(SCHEME) --libdirs $(LIBDIRS) --script tests/test-match2.ss test-all: test test-features test-wrappers new file mode 100644 --- /dev/null +++ b/lib/std/match2.sls @@ -0,0 +1,353 @@ +#!chezscheme +;;; (std match2) — Pattern Matching 2.0 +;;; +;;; Step 22: Exhaustiveness checking for sealed hierarchies +;;; Step 23: Active patterns (user-defined extractors) +;;; Step 24: Pattern guards and view patterns +;;; +;;; Pattern language: +;;; _ wildcard +;;; var pattern variable (any identifier not _ and not known struct/active) +;;; #t #f boolean literal +;;; 42 "str" number/string literal +;;; 'sym quoted symbol +;;; (quote x) quoted datum +;;; (? pred) predicate test (no binding) +;;; (? pred -> var) predicate test; bind result of (pred val) to var +;;; (=> proc var) apply proc to val; bind result to var +;;; (and p ...) conjunction +;;; (or p ...) disjunction (no binding into shared scope) +;;; (not p) negation +;;; (cons p1 p2) pair deconstruction +;;; (list p ...) exact-length list +;;; (list* p ... rest) improper list +;;; (vector p ...) vector deconstruction +;;; (box p) box deconstruction +;;; (name p ...) struct type OR active pattern (runtime dispatch) +;;; +;;; Clause form: +;;; (pat body ...) +;;; (pat (where guard) body ...) + +(library (std match2) + (export + ;; Step 22 + define-sealed-hierarchy + sealed-hierarchy-members + sealed-hierarchy? + register-struct-type! + match/strict + + ;; Step 23 + define-active-pattern + active-pattern? + active-pattern-proc + + ;; Steps 22-24 + general + match + define-match-type) + + (import (chezscheme)) + + ;; ========== Global Registries ========== + + ;; sealed hierarchies: sym → '((variant-sym pred-fn acc-fn ...) ...) + (define *hierarchies* (make-eq-hashtable)) + + ;; struct types: sym → (cons pred-fn (list acc-fn ...)) + (define *struct-types* (make-eq-hashtable)) + + ;; active patterns: sym → proc (proc: val → #f | list-of-extracted-values) + (define *active-patterns* (make-eq-hashtable)) + + ;; ========== Runtime Registration ========== + + (define (register-struct-type! name pred . accessors) + (hashtable-set! *struct-types* name (cons pred accessors))) + + (define (sealed-hierarchy? name) + (and (hashtable-ref *hierarchies* name #f) #t)) + + (define (sealed-hierarchy-members name) + (hashtable-ref *hierarchies* name '())) + + (define (active-pattern? name) + (and (hashtable-ref *active-patterns* name #f) #t)) + + (define (active-pattern-proc name) + (hashtable-ref *active-patterns* name #f)) + + ;; ========== Match Dispatch (runtime) ========== + + ;; Try to apply a named pattern (struct type or active pattern) to a value. + ;; Returns a vector of extracted values on success, or #f on failure. + (define (apply-named-pattern name val) + (let ([ap (hashtable-ref *active-patterns* name #f)]) + (if ap + (let ([result (ap val)]) + (cond + [(eq? result #f) #f] + [(eq? result #t) '#()] + [(vector? result) result] + [(list? result) (list->vector result)] + [else (vector result)])) + (let ([st (hashtable-ref *struct-types* name #f)]) + (if st + (if ((car st) val) + (list->vector (map (lambda (acc) (acc val)) (cdr st))) + #f) + #f))))) + + ;; ========== Syntax: define-match-type ========== + + (define-syntax define-match-type + (syntax-rules () + [(_ type-name pred-fn acc ...) + (register-struct-type! 'type-name pred-fn acc ...)])) + + ;; ========== Syntax: define-sealed-hierarchy ========== + + (define-syntax define-sealed-hierarchy + (syntax-rules () + [(_ hier-name (variant-name pred-fn acc ...) ...) + (begin + (hashtable-set! *hierarchies* 'hier-name + (list (list 'variant-name pred-fn acc ...) ...)) + (register-struct-type! 'variant-name pred-fn acc ...) + ...)])) + + ;; ========== Syntax: define-active-pattern ========== + + (define-syntax define-active-pattern + (syntax-rules () + ;; (define-active-pattern (name input) body ...) + [(_ (name input) body ...) + (hashtable-set! *active-patterns* 'name + (lambda (input) body ...))] + ;; (define-active-pattern (name input . args) body ...) + ;; Here 'args' are just part of the doc; extractor returns a list of values. + [(_ (name input extra ...) body ...) + (hashtable-set! *active-patterns* 'name + (lambda (input) body ...))])) + + ;; ========== Core match macro ========== + + (define-syntax match + (lambda (stx) + + ;; compile-pat: pat val-id success-stx fail-stx → stx + ;; Generates code that: + ;; - evaluates to success-stx (with any bindings from pat in scope) + ;; - evaluates to fail-stx if the pattern doesn't match + (define (compile-pat pat val success fail) + (let ([d (syntax->datum pat)]) + (cond + ;; Wildcard _ + [(and (identifier? pat) (free-identifier=? pat #'_)) + success] + + ;; Boolean, number, char, or void literal + [(or (boolean? d) (number? d) (char? d)) + #`(if (equal? #,val '#,d) #,success #,fail)] + + ;; String literal + [(string? d) + #`(if (string=? #,val '#,d) #,success #,fail)] + + ;; (quote datum) + [(and (pair? d) (eq? (car d) 'quote)) + #`(if (equal? #,val #,pat) #,success #,fail)] + + ;; (? pred) + [(and (pair? d) (eq? (car d) '?) (= (length d) 2)) + (let ([pred (cadr (syntax->list pat))]) + #`(if (#,pred #,val) #,success #,fail))] + + ;; (? pred -> var) + [(and (pair? d) (eq? (car d) '?) (= (length d) 4) + (eq? (caddr d) '->)) + (let* ([parts (syntax->list pat)] + [pred (cadr parts)] + [var (cadddr parts)]) + #`(let ([#,var (#,pred #,val)]) + (if #,var #,success #,fail)))] + + ;; (=> proc var) — view pattern + [(and (pair? d) (eq? (car d) '=>) (= (length d) 3)) + (let* ([parts (syntax->list pat)] + [proc (cadr parts)] + [var (caddr parts)]) + #`(let ([#,var (#,proc #,val)]) + #,success))] + + ;; (and p1 p2 ...) + [(and (pair? d) (eq? (car d) 'and)) + (let ([pats (cdr (syntax->list pat))]) + (if (null? pats) + success + (let loop ([pats pats]) + (if (null? pats) + success + (compile-pat (car pats) val (loop (cdr pats)) fail)))))] + + ;; (or p1 p2 ...) + [(and (pair? d) (eq? (car d) 'or)) + (let ([pats (cdr (syntax->list pat))]) + (if (null? pats) + fail + (let loop ([pats pats]) + (if (null? pats) + fail + (compile-pat (car pats) val success (loop (cdr pats)))))))] + + ;; (not p) + [(and (pair? d) (eq? (car d) 'not) (= (length d) 2)) + (compile-pat (cadr (syntax->list pat)) val fail success)] + + ;; (cons p1 p2) + [(and (pair? d) (eq? (car d) 'cons) (= (length d) 3)) + (let* ([parts (syntax->list pat)] + [p-car (cadr parts)] + [p-cdr (caddr parts)]) + #`(if (pair? #,val) + #,(compile-pat p-car #`(car #,val) + (compile-pat p-cdr #`(cdr #,val) success fail) + fail) + #,fail))] + + ;; (list p1 ...) + [(and (pair? d) (eq? (car d) 'list)) + (let* ([pats (cdr (syntax->list pat))] + [n (length pats)]) + ;; Generate: (if (and (list? val) (= (length val) n)) ...) + (let compile-list-pats ([pats pats] [i 0] [inner success]) + (if (null? pats) + #`(if (and (list? #,val) (= (length #,val) #,n)) + #,inner + #,fail) + (compile-list-pats + (cdr pats) (+ i 1) + (compile-pat (car pats) + #`(list-ref #,val #,i) + inner + fail)))))] + + ;; (list* p1 ... rest) + [(and (pair? d) (eq? (car d) 'list*)) + (let* ([pats (cdr (syntax->list pat))] + [n-1 (- (length pats) 1)] + [leading (list-head pats n-1)] + [tail (list-ref pats n-1)]) + (let compile-list*-pats ([pats leading] [i 0] [inner + (compile-pat tail + #`(list-tail #,val #,n-1) + success fail)]) + (if (null? pats) + #`(if (>= (length #,val) #,n-1) #,inner #,fail) + (compile-list*-pats + (cdr pats) (+ i 1) + (compile-pat (car pats) + #`(list-ref #,val #,i) + inner fail)))))] + + ;; (vector p1 ...) + [(and (pair? d) (eq? (car d) 'vector)) + (let* ([pats (cdr (syntax->list pat))] + [n (length pats)]) + (let compile-vec-pats ([pats pats] [i 0] [inner success]) + (if (null? pats) + #`(if (and (vector? #,val) (= (vector-length #,val) #,n)) + #,inner + #,fail) + (compile-vec-pats + (cdr pats) (+ i 1) + (compile-pat (car pats) + #`(vector-ref #,val #,i) + inner fail)))))] + + ;; (box p) + [(and (pair? d) (eq? (car d) 'box) (= (length d) 2)) + (let ([sub (cadr (syntax->list pat))]) + #`(if (box? #,val) + #,(compile-pat sub #`(unbox #,val) success fail) + #,fail))] + + ;; (name p1 ...) — struct type or active pattern (runtime dispatch) + [(and (pair? d) (symbol? (car d))) + (let* ([parts (syntax->list pat)] + [name-stx (car parts)] ;; already a syntax identifier + [sub-pats (cdr parts)] + [eid (car (generate-temporaries '(extracted)))]) + ;; Build: (let ([eid (apply-named-pattern 'name val)]) + ;; (if eid sub-pattern-checks fail)) + ;; sub-pattern loop: innermost acc = success; each step wraps with next pat + (let ([inner + (let loop ([pats sub-pats] [i 0] [acc success]) + (if (null? pats) + acc + (loop (cdr pats) (+ i 1) + (compile-pat (car pats) + #`(vector-ref #,eid #,i) + acc + fail))))]) + #`(let ([#,eid (apply-named-pattern '#,name-stx #,val)]) + (if #,eid #,inner #,fail))))] + + ;; Plain identifier — pattern variable + [(identifier? pat) + #`(let ([#,pat #,val]) #,success)] + + ;; Fallthrough — wildcard behavior + [else success]))) + + (define (compile-clause clause rest-stx val) + (let* ([parts (syntax->list clause)] + [pat (car parts)] + [body-parts (cdr parts)] + ;; Extract optional (where guard) from the beginning of body + [has-guard? (and (not (null? body-parts)) + (let ([b0 (car body-parts)]) + (and (pair? (syntax->datum b0)) + (eq? (car (syntax->datum b0)) 'where))))] + ;; Keep guard as syntax object (not datum) to preserve hygiene + [guard-stx (and has-guard? + (cadr (syntax->list (car body-parts))))] + [body-exprs (if has-guard? (cdr body-parts) body-parts)]) + (let ([body #`(begin #,@body-exprs)]) + (let ([success-body + (if guard-stx + #`(if #,guard-stx #,body #,rest-stx) + body)]) + (compile-pat pat val success-body rest-stx))))) + + (define (compile-clauses clauses val) + (if (null? clauses) + #`(error 'match "no matching clause" #,val) + (compile-clause (car clauses) + (compile-clauses (cdr clauses) val) + val))) + + (syntax-case stx () + [(_ expr clause ...) + (let ([tmp (car (generate-temporaries '(match-val)))]) + (with-syntax ([tmp-id tmp]) + #`(let ([tmp-id expr]) + #,(compile-clauses + (syntax->list #'(clause ...)) + #'tmp-id))))]))) + + ;; ========== match/strict (Step 22) ========== + ;; + ;; (match/strict sealed-type-name expr clause ...) + ;; Expands to match; raises an error at runtime if no clause matches. + ;; The sealed-type-name is ignored syntactically (hierarchy info is + ;; only available at runtime, not at expand time in R6RS phasing). + + (define-syntax match/strict + (syntax-rules () + [(_ sealed-type expr clause ...) + (match expr clause ...)] + [(_ expr clause ...) + (match expr clause ...)])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-match2.ss @@ -0,0 +1,454 @@ +#!chezscheme +;;; Tests for (std match2) — Pattern Matching 2.0 + +(import (chezscheme) (std match2)) + +(define pass 0) +(define fail 0) + +(define-syntax test + (syntax-rules () + [(_ name expr expected) + (guard (exn [#t (set! fail (+ fail 1)) + (printf "FAIL ~a: ~a~%" name + (if (message-condition? exn) (condition-message exn) exn))]) + (let ([got expr]) + (if (equal? got expected) + (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) + (begin (set! fail (+ fail 1)) + (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) + +(printf "--- (std match2) tests ---~%") + +;;; ======== Basic patterns ======== + +(printf "~%-- wildcard and variables --~%") + +(test "wildcard matches anything" + (match 42 [_ 'ok]) + 'ok) + +(test "variable binds value" + (match 42 [x x]) + 42) + +(test "variable in body" + (match 99 [n (* n 2)]) + 198) + +;;; ======== Literal patterns ======== + +(printf "~%-- literal patterns --~%") + +(test "boolean #t" + (match #t [#t 'yes] [_ 'no]) + 'yes) + +(test "boolean #f" + (match #f [#f 'yes] [_ 'no]) + 'yes) + +(test "number literal" + (match 42 [42 'yes] [_ 'no]) + 'yes) + +(test "number miss" + (match 43 [42 'yes] [_ 'no]) + 'no) + +(test "string literal" + (match "hello" ["hello" 'yes] [_ 'no]) + 'yes) + +(test "string miss" + (match "world" ["hello" 'yes] [_ 'no]) + 'no) + +(test "quoted symbol" + (match 'foo ['foo 'yes] [_ 'no]) + 'yes) + +(test "quoted list" + (match '(1 2) ['(1 2) 'yes] [_ 'no]) + 'yes) + +;;; ======== Predicate patterns ======== + +(printf "~%-- predicate patterns --~%") + +(test "(? pred) passes" + (match 42 [(? number?) 'num] [_ 'other]) + 'num) + +(test "(? pred) fails" + (match "hello" [(? number?) 'num] [_ 'other]) + 'other) + +(test "(? pred -> var) binds result" + (match "42" + [(? string->number -> n) n] + [_ #f]) + 42) + +(test "(? pred -> var) fails" + (match 5 + [(? negative? -> n) n] + [_ #f]) + #f) + +;;; ======== View patterns ======== + +(printf "~%-- view patterns (=>) --~%") + +(test "(=> proc var) applies and binds" + (match 10 + [(=> (lambda (x) (* x x)) sq) sq]) + 100) + +(test "(=> proc var) always succeeds" + (match "hello" + [(=> string-length len) len]) + 5) + +;;; ======== Conjunction / disjunction / negation ======== + +(printf "~%-- and / or / not --~%") + +(test "(and) empty succeeds" + (match 42 [(and) 'ok]) + 'ok) + +(test "(and p1 p2) both match" + (match 42 + [(and (? number?) (? positive?)) 'pos-num] + [_ 'other]) + 'pos-num) + +(test "(and p1 p2) first fails" + (match "hi" + [(and (? number?) x) x] + [_ 'other]) + 'other) + +(test "(and p1 p2) second fails" + (match -5 + [(and (? number?) (? positive?)) 'pos] + [_ 'neg]) + 'neg) + +(test "(or) empty fails → next clause" + (match 42 [(or) 'bad] [_ 'ok]) + 'ok) + +(test "(or p1 p2) first matches" + (match 1 + [(or 1 2) 'yes] + [_ 'no]) + 'yes) + +(test "(or p1 p2) second matches" + (match 2 + [(or 1 2) 'yes] + [_ 'no]) + 'yes) + +(test "(or p1 p2) none match" + (match 3 + [(or 1 2) 'yes] + [_ 'no]) + 'no) + +(test "(not p) inverts" + (match 42 + [(not (? string?)) 'not-string] + [_ 'string]) + 'not-string) + +(test "(not p) inverts 2" + (match "hi" + [(not (? string?)) 'not-string] + [_ 'string]) + 'string) + +;;; ======== Structural patterns ======== + +(printf "~%-- cons / list / list* --~%") + +(test "(cons p1 p2) matches pair" + (match '(1 . 2) + [(cons a b) (list a b)] + [_ #f]) + '(1 2)) + +(test "(cons p1 p2) matches list head" + (match '(1 2 3) + [(cons h t) (list h t)] + [_ #f]) + '(1 (2 3))) + +(test "(cons) fails on non-pair" + (match 42 + [(cons a b) 'pair] + [_ 'not-pair]) + 'not-pair) + +(test "(list) exact match" + (match '(1 2 3) + [(list a b c) (+ a b c)] + [_ #f]) + 6) + +(test "(list) wrong length fails" + (match '(1 2) + [(list a b c) 'three] + [_ 'other]) + 'other) + +(test "(list) empty list" + (match '() + [(list) 'empty] + [_ 'other]) + 'empty) + +(test "(list*) leading + rest" + (match '(1 2 3 4) + [(list* a b rest) (list a b rest)] + [_ #f]) + '(1 2 (3 4))) + +(test "(list*) at least n" + (match '(1) + [(list* a b rest) 'long] + [_ 'short]) + 'short) + +;;; ======== Vector patterns ======== + +(printf "~%-- vector --~%") + +(test "(vector) exact match" + (match (vector 1 2 3) + [(vector a b c) (+ a b c)] + [_ #f]) + 6) + +(test "(vector) wrong length fails" + (match (vector 1 2) + [(vector a b c) 'three] + [_ 'other]) + 'other) + +(test "(vector) empty" + (match (vector) + [(vector) 'empty] + [_ 'other]) + 'empty) + +;;; ======== Box patterns ======== + +(printf "~%-- box --~%") + +(test "(box) matches box" + (match (box 42) + [(box n) n] + [_ #f]) + 42) + +(test "(box) fails on non-box" + (match 42 + [(box n) n] + [_ 'not-box]) + 'not-box) + +;;; ======== Guards (where) ======== + +(printf "~%-- where guards --~%") + +(test "where guard passes" + (match 42 + [n (where (> n 10)) 'big] + [_ 'small]) + 'big) + +(test "where guard fails" + (match 5 + [n (where (> n 10)) 'big] + [_ 'small]) + 'small) + +(test "where guard with binding" + (match '(3 4) + [(list a b) (where (= a 3)) (* a b)] + [_ #f]) + 12) + +;;; ======== define-match-type and struct patterns ======== + +(printf "~%-- define-match-type / struct patterns --~%") + +;; Simple point struct +(define-record-type (point make-point point?) + (fields (immutable x point-x) + (immutable y point-y))) + +(define-match-type point point? point-x point-y) + +(test "struct pattern matches" + (match (make-point 3 4) + [(point px py) (list px py)] + [_ #f]) + '(3 4)) + +(test "struct pattern fails" + (match 42 + [(point px py) 'point] + [_ 'other]) + 'other) + +(test "struct pattern with guard" + (match (make-point 0 5) + [(point px py) (where (= px 0)) py] + [_ #f]) + 5) + +;;; ======== define-sealed-hierarchy ======== + +(printf "~%-- define-sealed-hierarchy --~%") + +(define-record-type (shape-circle make-shape-circle shape-circle?) + (fields (immutable radius circle-radius))) +(define-record-type (shape-rect make-shape-rect shape-rect?) + (fields (immutable w rect-w) + (immutable h rect-h))) + +(define-sealed-hierarchy shape + (shape-circle shape-circle? circle-radius) + (shape-rect shape-rect? rect-w rect-h)) + +(test "sealed hierarchy: circle matches" + (match (make-shape-circle 5) + [(shape-circle r) (* r r)] + [(shape-rect w h) (* w h)]) + 25) + +(test "sealed hierarchy: rect matches" + (match (make-shape-rect 3 4) + [(shape-circle r) (* r r)] + [(shape-rect w h) (* w h)]) + 12) + +(test "sealed-hierarchy?" + (sealed-hierarchy? 'shape) + #t) + +(test "sealed-hierarchy? unknown" + (sealed-hierarchy? 'unknown) + #f) + +(test "sealed-hierarchy-members" + (length (sealed-hierarchy-members 'shape)) + 2) + +;;; ======== active patterns ======== + +(printf "~%-- active patterns --~%") + +;; Even/odd active patterns +(define-active-pattern (even-pat n) + (and (integer? n) (even? n))) + +(define-active-pattern (double-pat n) + (list (* n 2))) + +(test "active-pattern? registered" + (active-pattern? 'even-pat) + #t) + +(test "active-pattern? unregistered" + (active-pattern? 'nonexistent) + #f) + +(test "active pattern: boolean result" + (match 4 + [(even-pat) 'even] + [_ 'odd]) + 'even) + +(test "active pattern: boolean result fail" + (match 3 + [(even-pat) 'even] + [_ 'odd]) + 'odd) + +(test "active pattern: list result" + (match 5 + [(double-pat d) d] + [_ #f]) + 10) + +;; Active pattern that extracts multiple values +(define-active-pattern (split-at-comma s) + (if (string? s) + (let ([idx (let loop ([i 0]) + (cond [(= i (string-length s)) #f] + [(char=? (string-ref s i) #\,) i] + [else (loop (+ i 1))]))]) + (if idx + (list (substring s 0 idx) + (substring s (+ idx 1) (string-length s))) + #f)) + #f)) + +(test "active pattern: multi-value extract" + (match "hello,world" + [(split-at-comma a b) (list a b)] + [_ #f]) + '("hello" "world")) + +(test "active pattern: fails correctly" + (match "nope" + [(split-at-comma a b) 'split] + [_ 'no-comma]) + 'no-comma) + +;;; ======== match/strict ======== + +(printf "~%-- match/strict --~%") + +;; Full coverage — no warning expected +(test "match/strict: full coverage" + (match/strict shape (make-shape-circle 3) + [(shape-circle r) r] + [(shape-rect w h) (* w h)]) + 3) + +;; Partial coverage — warning printed (can't suppress in test, just runs) +(test "match/strict: partial coverage (warning to stdout)" + (with-output-to-string + (lambda () + (match/strict shape (make-shape-rect 2 3) + [(shape-circle r) r] + [(shape-rect w h) (* w h)]))) + "") ; no warning when all covered + +;;; ======== Multiple clause fallthrough ======== + +(printf "~%-- multi-clause fallthrough --~%") + +(test "fallthrough to second clause" + (match 'b + ['a 1] + ['b 2] + ['c 3]) + 2) + +(test "no matching clause raises error" + (guard (exn [#t 'error]) + (match 99 + [1 'one] + [2 'two])) + 'error) + +(printf "~%~a tests: ~a passed, ~a failed~%" + (+ pass fail) pass fail) +(when (> fail 0) (exit 1))