84 lines
3.0 KiB
Racket
84 lines
3.0 KiB
Racket
#lang racket/base
|
|
(require unstable/struct
|
|
(for-syntax racket/base racket/struct-info unstable/struct))
|
|
(provide match make)
|
|
|
|
(define-syntax (match stx)
|
|
(syntax-case stx ()
|
|
[(match e clause ...)
|
|
#`(let ([x e])
|
|
(match-c x
|
|
clause ...
|
|
[_ (error 'minimatch "match at ~s:~s:~s failed: ~e"
|
|
'#,(syntax-source stx)
|
|
'#,(syntax-line stx)
|
|
'#,(syntax-column stx)
|
|
x)]))]))
|
|
|
|
(define-syntax match-c
|
|
(syntax-rules ()
|
|
[(match-c x)
|
|
(error 'minimatch)]
|
|
[(match-c x [pattern result ...] clause ...)
|
|
(let ([fail (lambda () (match-c x clause ...))])
|
|
(match-p x pattern (let () result ...) (fail)))]))
|
|
|
|
;; (match-p id Pattern SuccessExpr FailureExpr)
|
|
(define-syntax (match-p stx)
|
|
(syntax-case stx (quote cons list make struct)
|
|
[(match-p x wildcard success failure)
|
|
(and (identifier? #'wildcard) (free-identifier=? #'wildcard #'_))
|
|
#'success]
|
|
[(match-p x (quote lit) success failure)
|
|
#'(if (equal? x (quote lit))
|
|
success
|
|
failure)]
|
|
[(match-p x (cons p1 p2) success failure)
|
|
#'(if (pair? x)
|
|
(let ([x1 (car x)]
|
|
[x2 (cdr x)])
|
|
(match-p x1 p1 (match-p x2 p2 success failure) failure))
|
|
failure)]
|
|
[(match-p x (list) success failure)
|
|
#'(match-p x (quote ()) success failure)]
|
|
[(match-p x (list p1 p ...) success failure)
|
|
#'(match-p x (cons p1 (list p ...)) success failure)]
|
|
[(match-p x var success failure)
|
|
(identifier? #'var)
|
|
#'(let ([var x]) success)]
|
|
[(match-p x (make S p ...) success failure)
|
|
#'(match-p x (struct S (p ...)) success failure)]
|
|
[(match-p x (struct S (p ...)) success failure)
|
|
(identifier? #'S)
|
|
(let ()
|
|
(define (not-a-struct)
|
|
(raise-syntax-error #f "expected struct name" #'S))
|
|
(define si (syntax-local-value #'S not-a-struct))
|
|
(unless (struct-info? si)
|
|
(not-a-struct))
|
|
(let* ([si (extract-struct-info si)]
|
|
[predicate (list-ref si 2)]
|
|
[accessors (reverse (list-ref si 3))])
|
|
(unless (andmap identifier? accessors)
|
|
(raise-syntax-error #f "struct has incomplete information" #'S))
|
|
(with-syntax ([predicate predicate]
|
|
[(accessor ...) accessors])
|
|
#'(if (predicate x)
|
|
(let ([y (list (accessor x) ...)])
|
|
(match-p y (list p ...) success failure))
|
|
failure))))]
|
|
[(match-p x s success failure)
|
|
(prefab-struct-key (syntax-e #'s))
|
|
(with-syntax ([key (prefab-struct-key (syntax-e #'s))]
|
|
[(p ...) (struct->list (syntax-e #'s))])
|
|
#'(let ([xkey (prefab-struct-key x)])
|
|
(if (equal? xkey 'key)
|
|
(let ([xps (cdr (vector->list (struct->vector x)))])
|
|
(match-p xps (list p ...) success failure))
|
|
failure)))]))
|
|
|
|
#;
|
|
(define-syntax struct
|
|
(lambda (stx)
|
|
(raise-syntax-error #f "illegal use of keyword" stx)))
|