match-test.ss

#!r6rs

(import (rnrs) (srfi :78) (felis match))

(check (match 2 [_ 3]) => 3)
(check (match 2 [x x]) => 2)
(check (match 'foo ['foo 2] [_ 3]) => 2)
(check (match 'foo ['bar 2] [_ 3]) => 3)
(check (match 2 [(= number->string x) x]) => "2")
(check (match 2 [(and) 3] [_ 5]) => 3)
(check (match 2 [(and x) x] [_ 5]) => 2)
(check (match 2 [(and x (? number?) (? even?)) x] [_ 5]) => 2)
(check (match 2 [(and x (? number?) (? odd?)) x] [_ 5]) => 5)
(check (match 2 [(or 2 3) 5]) => 5)
(check (match 2 [(or x x) x]) => 2)
(check (match '(2 1 2) [(or (2 x y) (3 y x)) (list x y)]) => `(1 2))
(check (match 2 [(not (? number?)) 3] [_ 5]) => 5)
(check (match 2 [(not (? string?)) 3] [_ 5]) => 3)
(check (match 2 [(? number?) 3] [_ 5]) => 3)
(check (match 2 [(? string?) 3] [_ 5]) => 5)
(check (match 2 [(? number? x) x] [_ 5]) => 2)
(check (match 2 [2 3] [_ 5]) => 3)
(check (match '() [() 2] [_ 3]) => 2)
(check (match '(1 2 3) [(x y z) (list x y z)] [_ 5]) => '(1 2 3))
(check (match '(1 2 3) [((? number? x) ...) x]) => '(1 2 3))
(check (match '(1 2 3) [((? string? x) ...) x] [_ 5]) => 5)
(check (match '(1 2 3) [(x __3) x] [_ 5]) => '(1 2 3))
(check (match '(1 2 3) [(x __4) x] [_ 5]) => 5)
(check (match '(1 2 3) [(x y ...) (list x y)]) => '(1 (2 3)))
(check (match '#(1 2 3) [#(x y z) (list x y z)]) => '(1 2 3))
(check (match '#(1 2 3) [#((? number? x) ...) x]) => '(1 2 3))
(check (match '#(1 2 3) [#((? string? x) ...) x] [_ 5]) => '5)
(check (match '#(1 2 3) [#(x __3) x] [_ 5]) => '(1 2 3))
(check (match '#(1 2 3) [#(x __4) x] [_ 5]) => 5)


(define-record-type abc
  (fields a (mutable b) c)
  (opaque #f))
(check (match (make-abc 1 2 3) [($ abc x y z) (list x y z)]) => '(1 2 3))
(check (match 2 [($ abc x y z) (list x y z)] [_ 3]) => 3)


(check (match '(1 2 3) [(x (get! y) z) (list x (y) z)]) => '(1 2 3))
(check (match '(1 2 3) [(x (and (set! y!) (get! y)) z) (y! 4) (list x (y) z)])
       => '(1 4 3))

(check (match '#(1 2 3) [#(x (get! y) z) (list x (y) z)]) => '(1 2 3))
(check (match (vector 1 2 3) [#(x (and (set! y!) (get! y)) z) (y! 4) (list x (y) z)])
       => '(1 4 3))

(check (match (make-abc 1 2 3) [($ abc x (get! y) z) (list x (y) z)]) => '(1 2 3))
(check (match (make-abc 1 2 3) [($ abc x (and (set! y!) (get! y)) z) (y! 4) (list x (y) z)])
       => '(1 4 3))

(check (match '(1 2 3) [`(,x ,y ,z) (list x y z)]) => '(1 2 3))
(check (match '(1 2 3) [`(,@(x y) ,z) (list x y z)]) => '(1 2 3))
(check (match '(1 2 3) [`(,x ,@(y z)) (list x y z)]) => '(1 2 3))
(check (match '(1 2 3) [`(,x ,@y) (list x y)]) => '(1 (2 3)))
(check (match '#(1 2 3) [`#(,x ,y ,z) (list x y z)]) => '(1 2 3))
(check (match '#(1 2 3) [`#(,@(x y) ,z) (list x y z)]) => '(1 2 3))
(check (match '#(1 2 3) [`#(,x ,@(y z)) (list x y z)]) => '(1 2 3))
(check (match '_ [`_ 3]) => 3)
(check (match '$ [`$ 3]) => 3)
(check (match '= [`= 3]) => 3)
(check (match 'and [`and 3]) => 3)
(check (match 'or [`or 3]) => 3)
(check (match 'not [`not 3]) => 3)
(check (match '? [`? 3]) => 3)
(check (match 'get! [`get! 3]) => 3)
(check (match 'set! [`set! 3]) => 3)
(check (match '... [`... 3]) => 3)
(check (match '__3 [`__3 3]) => 3)
(check (match '() [`() 3]) => 3)
(check (match 2 [`2 3]) => 3)
(check (match 'foo [`foo 2] [_ 3]) => 2)
(check (match 'foo [`bar 2] [_ 3]) => 3)

(check-report)

match.ss

#!r6rs

(library (felis match)
  
  (export match match-lambda match-lambda* match-let match-let*)
  
  (import (rnrs) (rnrs mutable-pairs))
  
  (define-syntax match
    (syntax-rules ()
      [(_ exp clause ...)
       (let ([t exp])
         (match-next t clause ...))]))
  
  (define-syntax match-next
    (syntax-rules (=>)
      [(_ t) (error 'match "unmatch" t)]
      [(_ t (pat (=> escape) body ...) clause ...)
       (let ([failure (lambda () (match-next t clause ...))])
         (match-clause
          t pat
          (call/cc
           (lambda (k)
             (let ([escape (lambda () (call-with-values failure k))])
               body ...)))
          failure))]
      [(_ t (pat body ...) clause ...)
       (let ([failure (lambda () (match-next t clause ...))])
         (match-clause t pat (let () body ...) failure))]))
  
  (define-syntax match-clause
    (lambda (x)
      
      (define (self-evaluating? x)
        (or (boolean? x) (number? x) (string? x) (char? x)))
      
      (define (underscore? x)
        (and (identifier? x) (free-identifier=? x #'_)))
      
      (define (ellipsis? x)
        (and (identifier? x)
             (or (free-identifier=? x #'(... ...))
                 (free-identifier=? x #'___)
                 (let* ([sym (syntax->datum x)]
                        [str (symbol->string sym)]
                        [len (string-length str)])
                   (and (free-identifier=? x (datum->syntax #'dummy sym))
                        (<= 3 len)
                        (memv (string-ref str 0) '(#\. #\_))
                        (char=? (string-ref str 0) (string-ref str 1))
                        (for-all (lambda (c) (char<=? #\0 c #\9))
                          (string->list (substring str 2 len))))))))
      
      (define (ellipsis-k ooo)
        (if (or (free-identifier=? ooo #'(... ...))
                (free-identifier=? ooo #'___))
            0
            (let ([str (symbol->string (syntax->datum ooo))])
              (string->number
               (substring str 2 (string-length str))))))
      
      (define (pattern-variable? x)
        (and (identifier? x)
             (not (ellipsis? x))
             (for-all (lambda (key) (not (free-identifier=? key x)))
               (list #'quote #'quasiquote #'unquote #'unquote-splicing
                     #'_ #'$ #'= #'and #'or #'not #'? #'get! #'set!))))
      
      (define iota
        (case-lambda
          [(count) (iota count 0)]
          [(count start) (iota count start 1)]
          [(count start step)
           (if (zero? count)
               '()
               (cons start (iota (- count 1) (+ start step) step)))]))
      
      (define (lset-eq? lset1 lset2)
        (and (= (length lset1) (length lset2))
             (for-all
                 (lambda (e1)
                   (memp (lambda (e2) (bound-identifier=? e1 e2)) lset2))
               lset1)))

      (define (getter loc)
        (if loc
            #`(lambda () #,loc)
            (syntax-violation 'match "get! pattern error" loc)))

      (define (setter loc)
        (syntax-case loc (car cdr record-accessor vector-accessor)
          [(car t) #'(lambda (v) (set-car! t v))]
          [(cdr t) #'(lambda (v) (set-cdr! t v))]
          [((record-accessor rtd k) t)
           #'(lambda (v) ((record-mutator rtd k) t v))]
          [((vector-accessor k) t)
           #'(lambda (v) (vector-set! t k v))]))
      
      (define (scan t pat vars vals C loc)
        (define (scan-pat pat)
          (syntax-case pat (quote quasiquote $ = and or not ? get! set!)
            ['datum (values vars vals (cons #`(if (equal? #,t 'datum)) C))]
            [`qp (scan-pat (scan-qp #'qp))]
            [($ record pat ...)
             (with-syntax ([(k ...) (iota (length #'(pat ...)))])
               (scan-pat
                #'(? (record-predicate (record-type-descriptor record))
                     (= (record-accessor (record-type-descriptor record) k) pat)
                     ...)))]
            [(= field pat)
             (with-syntax ([(tt) (generate-temporaries #'(field))])
               (scan #'tt #'pat vars vals (cons #`(let ([tt (field #,t)])) C)
                     #`(field #,t)))]
            [(and pat ...) (scan-and #'(pat ...))]
            [(or pat ...) (scan-or #'(pat ...))]
            [(not) (values vars vals C)]
            [(not pat)
             (let-values ([(vars1 vals1 C1) (scan t #'pat '() '() '() loc)])
               (values vars vals (cons #`(not #,C1) C)))]
            [(not pat ...) (scan-pat #'(and (not pat) ...))]
            [(? predicate) (values vars vals (cons #`(if (predicate #,t)) C))]
            [(? predicate pat ...) (scan-pat #'(and (? predicate) pat ...))]
            [(get! id) (values (cons #'id vars) (cons (getter loc) vals) C)]
            [(set! id) (values (cons #'id vars) (cons (setter loc) vals) C)]
            [(pat ooo)
             (ellipsis? #'ooo)
             (let-values ([(vars1 vals1 C1) (scan t #'pat '() '() '() loc)])
               (with-syntax ([(ttt ...) (generate-temporaries vals1)])
                 (values (append vars1 vars) (append vals1 vals)
                         (cons #`(list-ellipsis
                                  #,t #,(ellipsis-k #'ooo)
                                  #,vals1 (ttt ...) #,C1) C))))]
            [(pat1 . pat2) (scan-pat #'(? pair? (= car pat1) (= cdr pat2)))]
            [() (scan-pat #'(? null?))]
            [#(pat1 ... pat2 ooo)
             (ellipsis? #'ooo)
             (let-values ([(vars vals C) (scan t #'#(pat1 ...) vars vals C loc)]
                          [(vars1 vals1 C1) (scan t #'pat2 '() '() '() loc)])
               (with-syntax ([(ttt ...) (generate-temporaries vals1)])
                 (values (append vars1 vars) (append vals1 vals)
                         (cons #`(vector-ellipsis
                                  #,(length #'(pat1 ...))
                                  #,t #,(ellipsis-k #'ooo)
                                  #,vals1 (ttt ...) #, C1) C))))]
            [#(pat ...)
             (with-syntax ([(k ...) (iota (length #'(pat ...)))])
               (scan-pat #'(? vector? (= (vector-accessor k) pat) ...)))]
            [id (underscore? #'id) (values vars vals C)]
            [id (pattern-variable? #'id)
                (if (memp (lambda (var) (bound-identifier=? #'id var)) vars)
                    (syntax-violation #f "duplicated binding" #'id)
                    (values (cons #'id vars) (cons t vals) C))]
            [v (self-evaluating? (syntax->datum #'v)) (scan-pat #''v)]))

        (define (scan-qp qp)
          (syntax-case qp (unquote unquote-splicing)
            [,pat #'pat]
            [(,@pat) #'pat]
            [(,@(pat ...) . qp) #`(pat ... . #,(scan-qp #'qp))]
            [(qp ooo) (ellipsis? #'ooo) #`(#,(scan-qp #'qp) ooo)]
            [(qp1 . qp2) #`(#,(scan-qp #'qp1) . #,(scan-qp #'qp2))]
            [() #'()]
            [#(qp ...)
             (with-syntax ([(pat ...) (scan-qp-vector #'(qp ...))])
               #'#(pat ...))]
            [id (identifier? #'id) #''id]
            [v (self-evaluating? (syntax->datum #'v)) #'v]))

        (define (scan-qp-vector qp*)
          (syntax-case qp* (unquote unquote-splicing)
            [(,@(pat ...) qp ...) #`(pat ... #,@(scan-qp-vector #'(qp ...)))]
            [(qp ooo) (ellipsis? #'ooo) #`(#,(scan-qp #'qp) ooo)]
            [(qp1 qp2 ...) #`(#,(scan-qp #'qp1) #,@(scan-qp-vector #'(qp2 ...)))]
            [() #'()]))

        (define (scan-and pat*)
          (syntax-case pat* ()
            [() (values vars vals C)]
            [(pat1 pat2 ...)
             (let-values ([(vars vals C) (scan t #'pat1 vars vals C loc)])
               (scan t #'(and pat2 ...) vars vals C loc))]))
        
        (define (scan-or pat*)
          (syntax-case pat* ()
            [() (values vars vals (cons #'(fail) C))]
            [(pat) (scan-pat #'pat)]
            [(pat1 pat2 ...)
             (let-values
                 ([(vars1 vals1 C1) (scan t #'pat1 '() '() '() loc)]
                  [(vars2 vals2 C2) (scan t #'(or pat2 ...) '() '() '() loc)])
               (if (lset-eq? vars1 vars2)
                   (values (append vars1 vars) (append vals1 vals)
                           (cons #`(or #,vars1 #,vals1 #,C1 #,vars2 #,vals2 #,C2) C))
                   (syntax-violation
                    'match "all subpatterns must bind the same set of pattern variables"
                    #'(or pat1 pat2 ...))))]))
        
        (scan-pat pat))

      
      (syntax-case x ()
        [(_ t pat expr failure)
         (let-values ([(vars vals C) (scan #'t #'pat '() '() '() #f)])
           (with-syntax ([(success) (generate-temporaries #'(success))])
             #`(let ([success (lambda #,vars expr)])
                 (fill #,C (success #,@vals) (failure)))))])))
  
  (define-syntax fill
    (syntax-rules (let if or not list-ellipsis vector-ellipsis)
      [(_ () sk fk) sk]
      [(_ ((let bindings) . C) sk fk)
       (fill C (let bindings sk) fk)]
      [(_ ((if test) . C) sk fk)
       (fill C (if test sk fk) fk)]
      [(_ ((or (var1 ...) (val1 ...) C1 (var2 ...) (val2 ...) C2) . C) sk fk)
       (fill C
             (let ([success1 (lambda (val1 ...) sk)])
               (let-syntax ([success2 (syntax-rules ()
                                        [(_ var2 ...) (success1 var1 ...)])])
                 (fill C1 (success1 val1 ...) (fill C2 (success2 val2 ...) fk))))
             fk)]
      [(_ ((not C0) . C) sk fk)
       (fill C (fill C0 fk sk) fk)]
      [(_ ((list-ellipsis t k (val ...) (ttt ...) C0) . C) sk fk)
       (fill C
             (let loop ([len 0] [t t] [ttt '()] ...)
               (cond
                 [(null? t) (if (<= k len) (let ([val (reverse ttt)] ...) sk) fk)]
                 [(pair? t)
                  (let ([t (car t)] [tt (cdr t)])
                    (fill C0 (loop (+ len 1) tt (cons val ttt) ...) fk))]
                 [else fk]))
             fk)]
      [(_ ((vector-ellipsis i t k (val ...) (ttt ...) C0) . C) sk fk)
       (fill C
             (if (<= (+ i k) (vector-length t))
                 (let loop ([j i] [ttt '()] ...)
                   (if (< j (vector-length t))
                       (let ([t (vector-ref t j)])
                         (fill C0 (loop (+ j 1) (cons val ttt) ...) fk))
                       (let ([val (reverse ttt)] ...) sk)))
                 fk)
             fk)]))

  (define (vector-accessor k) (lambda (vec) (vector-ref vec k)))
  
  (define-syntax match-lambda
    (syntax-rules ()
      [(_ clause ...) (lambda (x) (match x clause ...))]))
  
  (define-syntax match-lambda*
    (syntax-rules ()
      [(_ clause ...) (lambda x (match x clause ...))]))
  
  (define-syntax match-let
    (syntax-rules ()
      [(_ ([pat expr] ...) body ...)
       (match (list expr ...)
         [(pat ...) body ...])]))
  
  (define-syntax match-let*
    (syntax-rules ()
      [(_ () body ...) (let () body ...)]
      [(_ ([pat expr]) body ...) (match expr [pat body ...])]
      [(_ ([pat1 expr1] [pat2 expr2] ...) body ...)
       (match expr1 [pat1 (match-let* ([pat2 expr2] ...) body ...)])]))
  )