Package "match"


Version:
v1.0.0
Released:
2231 days ago
Maintainer:
Matthew Martin <matt.a.martin@gmail.com>
Author:
Alex Shinn <foof@synthcode.com>
Homepage:
http://synthcode.com/scheme/
Description:
An R5RS hygienic pattern matcher backwards compatible with Andrew Wright's MATCH syntax.
Keywords:
syntax
Package form:
(package*
 match/v1.0.0
 (provide:
  (define-syntax
   match-syntax-error
   (syntax-rules
    ()
    ((_) (match-syntax-error "invalid match-syntax-error usage"))))
  (define-syntax
   match
   (syntax-rules
    ()
    ((match) (match-syntax-error "missing match expression"))
    ((match atom) (match-syntax-error "missing match clause"))
    ((match (app ...) (pat . body) ...)
     (let ((v (app ...)))
       (match-next v (app ...) (set! (app ...)) (pat . body) ...)))
    ((match #(vec ...) (pat . body) ...)
     (let ((v #(vec ...))) (match-next v v (set! v) (pat . body) ...)))
    ((match atom (pat . body) ...)
     (match-next atom atom (set! atom) (pat . body) ...))))
  (define-syntax
   match-next
   (syntax-rules
    (=>)
    ((match-next v g s) (error 'match "no matching pattern"))
    ((match-next v g s (pat (=> failure) . body) . rest)
     (let ((failure (lambda () (match-next v g s . rest))))
       (match-one v pat g s (match-drop-ids (begin . body)) (failure) ())))
    ((match-next v g s (pat . body) . rest)
     (match-next v g s (pat (=> failure) . body) . rest))))
  (define-syntax
   match-one
   (syntax-rules
    ()
    ((match-one v (p q . r) g s sk fk i)
     (match-check-ellipse
      q
      (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ())
      (match-two v (p q . r) g s sk fk i)))
    ((match-one . x) (match-two . x))))
  (define-syntax
   match-two
   (syntax-rules
    (_ ___ quote quasiquote ? $ = and or not set! get!)
    ((match-two v () g s (sk ...) fk i) (if (null? v) (sk ... i) fk))
    ((match-two v 'p g s (sk ...) fk i) (if (equal? v 'p) (sk ... i) fk))
    ((match-two v `p g s sk fk i) (match-quasiquote v p g s sk fk i))
    ((match-two v (and) g s (sk ...) fk i) (sk ... i))
    ((match-two v (and p q ...) g s sk fk i)
     (match-one v p g s (match-one v (and q ...) g s sk fk) fk i))
    ((match-two v (or) g s sk fk i) fk)
    ((match-two v (or p) g s sk fk i) (match-one v p g s sk fk i))
    ((match-two v (or p ...) g s sk fk i)
     (match-extract-vars (or p ...) (match-gen-or v (p ...) g s sk fk i) i ()))
    ((match-two v (not p) g s (sk ...) fk i)
     (match-one v p g s (match-drop-ids fk) (sk ... i) i))
    ((match-two v (get! getter) g s (sk ...) fk i)
     (let ((getter (lambda () g))) (sk ... i)))
    ((match-two v (set! setter) g (s ...) (sk ...) fk i)
     (let ((setter (lambda (x) (s ... x)))) (sk ... i)))
    ((match-two v (? pred p ...) g s sk fk i)
     (if (pred v) (match-one v (and p ...) g s sk fk i) fk))
    ((match-two v (= proc p) g s sk fk i)
     (let ((w (proc v))) (match-one w p g s sk fk i)))
    ((match-two v (p ___ . r) g s sk fk i)
     (match-extract-vars p (match-gen-ellipses v p r g s sk fk i) i ()))
    ((match-two v (p) g s sk fk i)
     (if (and (pair? v) (null? (cdr v)))
         (let ((w (car v))) (match-one w p (car v) (set-car! v) sk fk i))
         fk))
    ((match-two v (p . q) g s sk fk i)
     (if (pair? v)
         (let ((w (car v)) (x (cdr v)))
           (match-one
            w
            p
            (car v)
            (set-car! v)
            (match-one x q (cdr v) (set-cdr! v) sk fk)
            fk
            i))
         fk))
    ((match-two v #(p ...) g s sk fk i)
     (if (vector? v) (match-vector v 0 () (p ...) sk fk i) fk))
    ((match-two v _ g s (sk ...) fk i) (sk ... i))
    ((match-two v x g s (sk ...) fk (id ...))
     (let-syntax
      ((new-sym?
        (syntax-rules
         (id ...)
         ((new-sym? x sk2 fk2) sk2)
         ((new-sym? y sk2 fk2) fk2))))
      (new-sym?
       random-sym-to-match
       (let ((x v)) (sk ... (id ... x)))
       (if (equal? v x) (sk ... (id ...)) fk))))))
  (define-syntax
   match-quasiquote
   (syntax-rules
    (unquote . ,@quasiquote)
    ((_ v ,p g s sk fk i) (match-one v p g s sk fk i))
    ((_ v (,@p . rest) g s sk fk i)
     (if (pair? v)
         (match-one v (p . tmp) (match-quasiquote tmp rest g s sk fk) fk i)
         fk))
    ((_ v `p g s sk fk i . depth)
     (match-quasiquote v p g s sk fk i #f . depth))
    ((_ v ,p g s sk fk i x . depth) (match-quasiquote v p g s sk fk i . depth))
    ((_ v ,@p g s sk fk i x . depth)
     (match-quasiquote v p g s sk fk i . depth))
    ((_ v (p . q) g s sk fk i . depth)
     (if (pair? v)
         (let ((w (car v)) (x (cdr v)))
           (match-quasiquote
            w
            p
            g
            s
            (match-quasiquote-step x q g s sk fk depth)
            fk
            i
            .
            depth))
         fk))
    ((_ v #(elt ...) g s sk fk i . depth)
     (if (vector? v)
         (let ((ls (vector->list v)))
           (match-quasiquote ls (elt ...) g s sk fk i . depth))
         fk))
    ((_ v x g s sk fk i . depth) (match-one v 'x g s sk fk i))))
  (define-syntax
   match-quasiquote-step
   (syntax-rules
    ()
    ((match-quasiquote-step x q g s sk fk depth i)
     (match-quasiquote x q g s sk fk i . depth))))
  (define-syntax match-drop-ids (syntax-rules () ((_ expr ids ...) expr)))
  (define-syntax
   match-gen-or
   (syntax-rules
    ()
    ((_ v p g s (sk ...) fk (i ...) ((id id-ls) ...))
     (let ((sk2 (lambda (id ...) (sk ... (i ... id ...)))))
       (match-gen-or-step v p g s (match-drop-ids (sk2 id ...)) fk (i ...))))))
  (define-syntax
   match-gen-or-step
   (syntax-rules
    ()
    ((_ v () g s sk fk i) fk)
    ((_ v (p) g s sk fk i) (match-one v p g s sk fk i))
    ((_ v (p . q) g s sk fk i)
     (match-one v p g s sk (match-gen-or-step v q g s sk fk i) i))))
  (define-syntax
   match-gen-ellipses
   (syntax-rules
    ()
    ((_ v p () g s (sk ...) fk i ((id id-ls) ...))
     (match-check-identifier
      p
      (let ((p v)) (sk ... i))
      (let loop ((ls v) (id-ls '()) ...)
        (cond ((null? ls) (let ((id (reverse id-ls)) ...) (sk ... i)))
              ((pair? ls)
               (let ((w (car ls)))
                 (match-one
                  w
                  p
                  (car ls)
                  (set-car! ls)
                  (match-drop-ids (loop (cdr ls) (cons id id-ls) ...))
                  fk
                  i)))
              (else fk)))))
    ((_ v p (r ...) g s (sk ...) fk i ((id id-ls) ...))
     (match-verify-no-ellipses
      (r ...)
      (let* ((tail-len (length '(r ...))) (ls v) (len (length ls)))
        (if (< len tail-len)
            fk
            (let loop ((ls ls) (n len) (id-ls '()) ...)
              (cond ((= n tail-len)
                     (let ((id (reverse id-ls)) ...)
                       (match-one ls (r ...) #f #f (sk ... i) fk i)))
                    ((pair? ls)
                     (let ((w (car ls)))
                       (match-one
                        w
                        p
                        (car ls)
                        (set-car! ls)
                        (match-drop-ids
                         (loop (cdr ls) (- n 1) (cons id id-ls) ...))
                        fk
                        i)))
                    (else fk)))))))))
  (define-syntax
   match-verify-no-ellipses
   (syntax-rules
    ()
    ((_ (x . y) sk)
     (match-check-ellipse
      x
      (match-syntax-error
       "multiple ellipse patterns not allowed at same level")
      (match-verify-no-ellipses y sk)))
    ((_ x sk) sk)))
  (define-syntax
   match-vector
   (syntax-rules
    (___)
    ((_ v n pats (p q) sk fk i)
     (match-check-ellipse
      q
      (match-vector-ellipses v n pats p sk fk i)
      (match-vector-two v n pats (p q) sk fk i)))
    ((_ v n pats (p ___) sk fk i) (match-vector-ellipses v n pats p sk fk i))
    ((_ . x) (match-vector-two . x))))
  (define-syntax
   match-vector-two
   (syntax-rules
    ()
    ((_ v n ((pat index) ...) () sk fk i)
     (if (vector? v)
         (let ((len (vector-length v)))
           (if (= len n) (match-vector-step v ((pat index) ...) sk fk i) fk))
         fk))
    ((_ v n (pats ...) (p . q) sk fk i)
     (match-vector v (+ n 1) (pats ... (p n)) q sk fk i))))
  (define-syntax
   match-vector-step
   (syntax-rules
    ()
    ((_ v () (sk ...) fk i) (sk ... i))
    ((_ v ((pat index) . rest) sk fk i)
     (let ((w (vector-ref v index)))
       (match-one
        w
        pat
        (vector-ref v index)
        (vector-set! v index)
        (match-vector-step v rest sk fk)
        fk
        i)))))
  (define-syntax
   match-vector-ellipses
   (syntax-rules
    ()
    ((_ v n ((pat index) ...) p sk fk i)
     (if (vector? v)
         (let ((len (vector-length v)))
           (if (>= len n)
               (match-vector-step
                v
                ((pat index) ...)
                (match-vector-tail v p n len sk fk)
                fk
                i)
               fk))
         fk))))
  (define-syntax
   match-vector-tail
   (syntax-rules
    ()
    ((_ v p n len sk fk i)
     (match-extract-vars p (match-vector-tail-two v p n len sk fk i) i ()))))
  (define-syntax
   match-vector-tail-two
   (syntax-rules
    ()
    ((_ v p n len (sk ...) fk i ((id id-ls) ...))
     (let loop ((j n) (id-ls '()) ...)
       (if (>= j len)
           (let ((id (reverse id-ls)) ...) (sk ... i))
           (let ((w (vector-ref v j)))
             (match-one
              w
              p
              (vector-ref v j)
              (vetor-set! v j)
              (match-drop-ids (loop (+ j 1) (cons id id-ls) ...))
              fk
              i)))))))
  (define-syntax
   match-extract-vars
   (syntax-rules
    (_ ___ ? $ = quote quasiquote and or not get! set!)
    ((match-extract-vars (? pred . p) k i v) (match-extract-vars p k i v))
    ((match-extract-vars ($ rec . p) k i v) (match-extract-vars p k i v))
    ((match-extract-vars (= proc p) k i v) (match-extract-vars p k i v))
    ((match-extract-vars 'x (k ...) i v) (k ... v))
    ((match-extract-vars `x k i v)
     (match-extract-quasiquote-vars x k i v (#t)))
    ((match-extract-vars (and . p) k i v) (match-extract-vars p k i v))
    ((match-extract-vars (or . p) k i v) (match-extract-vars p k i v))
    ((match-extract-vars (not . p) k i v) (match-extract-vars p k i v))
    ((match-extract-vars (p q . r) k i v)
     (match-check-ellipse
      q
      (match-extract-vars (p . r) k i v)
      (match-extract-vars p (match-extract-vars-step (q . r) k i v) i ())))
    ((match-extract-vars (p . q) k i v)
     (match-extract-vars p (match-extract-vars-step q k i v) i ()))
    ((match-extract-vars #(p ...) k i v) (match-extract-vars (p ...) k i v))
    ((match-extract-vars _ (k ...) i v) (k ... v))
    ((match-extract-vars ___ (k ...) i v) (k ... v))
    ((match-extract-vars p (k ...) (i ...) v)
     (let-syntax
      ((new-sym?
        (syntax-rules
         (i ...)
         ((new-sym? p sk fk) sk)
         ((new-sym? x sk fk) fk))))
      (new-sym? random-sym-to-match (k ... ((p p-ls) . v)) (k ... v))))))
  (define-syntax
   match-extract-vars-step
   (syntax-rules
    ()
    ((_ p k i v ((v2 v2-ls) ...))
     (match-extract-vars p k (v2 ... . i) ((v2 v2-ls) ... . v)))))
  (define-syntax
   match-extract-quasiquote-vars
   (syntax-rules
    (quasiquote . ,unquote-splicing)
    ((match-extract-quasiquote-vars `x k i v d)
     (match-extract-quasiquote-vars x k i v (#t . d)))
    ((match-extract-quasiquote-vars ,@x k i v d)
     (match-extract-quasiquote-vars ,x k i v d))
    ((match-extract-quasiquote-vars ,x k i v (#t))
     (match-extract-vars x k i v))
    ((match-extract-quasiquote-vars ,x k i v (#t . d))
     (match-extract-quasiquote-vars x k i v d))
    ((match-extract-quasiquote-vars (x . y) k i v (#t . d))
     (match-extract-quasiquote-vars
      x
      (match-extract-quasiquote-vars-step y k i v d)
      i
      ()))
    ((match-extract-quasiquote-vars #(x ...) k i v (#t . d))
     (match-extract-quasiquote-vars (x ...) k i v d))
    ((match-extract-quasiquote-vars x (k ...) i v (#t . d)) (k ... v))))
  (define-syntax
   match-extract-quasiquote-vars-step
   (syntax-rules
    ()
    ((_ x k i v d ((v2 v2-ls) ...))
     (match-extract-quasiquote-vars x k (v2 ... . i) ((v2 v2-ls) ... . v) d))))
  (define-syntax
   match-lambda
   (syntax-rules () ((_ clause ...) (lambda (expr) (match expr clause ...)))))
  (define-syntax
   match-lambda*
   (syntax-rules () ((_ clause ...) (lambda expr (match expr clause ...)))))
  (define-syntax
   match-let
   (syntax-rules
    ()
    ((_ (vars ...) . body) (match-let/helper let () () (vars ...) . body))
    ((_ loop . rest) (match-named-let loop () . rest))))
  (define-syntax
   match-letrec
   (syntax-rules
    ()
    ((_ vars . body) (match-let/helper letrec () () vars . body))))
  (define-syntax
   match-let/helper
   (syntax-rules
    ()
    ((_ let ((var expr) ...) () () . body) (let ((var expr) ...) . body))
    ((_ let ((var expr) ...) ((pat tmp) ...) () . body)
     (let ((var expr) ...) (match-let* ((pat tmp) ...) . body)))
    ((_ let (v ...) (p ...) (((a . b) expr) . rest) . body)
     (match-let/helper
      let
      (v ... (tmp expr))
      (p ... ((a . b) tmp))
      rest
      .
      body))
    ((_ let (v ...) (p ...) ((#(a ...) expr) . rest) . body)
     (match-let/helper
      let
      (v ... (tmp expr))
      (p ... (#(a ...) tmp))
      rest
      .
      body))
    ((_ let (v ...) (p ...) ((a expr) . rest) . body)
     (match-let/helper let (v ... (a expr)) (p ...) rest . body))))
  (define-syntax
   match-named-let
   (syntax-rules
    ()
    ((_ loop ((pat expr var) ...) () . body)
     (let loop ((var expr) ...) (match-let ((pat var) ...) . body)))
    ((_ loop (v ...) ((pat expr) . rest) . body)
     (match-named-let loop (v ... (pat expr tmp)) rest . body))))
  (define-syntax
   match-let*
   (syntax-rules
    ()
    ((_ () . body) (begin . body))
    ((_ ((pat expr) . rest) . body)
     (match expr (pat (match-let* rest . body))))))
  (define-syntax
   match-check-ellipse
   (syntax-rules
    ()
    ((match-check-ellipse (a . b) success-k failure-k) failure-k)
    ((match-check-ellipse #(a ...) success-k failure-k) failure-k)
    ((match-check-ellipse id success-k failure-k)
     (let-syntax
      ((ellipse?
        (syntax-rules
         ()
         ((ellipse? (foo id) sk fk) sk)
         ((ellipse? other sk fk) fk))))
      (ellipse? (a b c) success-k failure-k)))))
  (define-syntax
   match-check-identifier
   (syntax-rules
    ()
    ((_ (x . y) success-k failure-k) failure-k)
    ((_ #(x ...) success-k failure-k) failure-k)
    ((_ x success-k failure-k)
     (let-syntax
      ((sym? (syntax-rules () ((sym? x sk fk) sk) ((sym? y sk fk) fk))))
      (sym? abracadabra success-k failure-k))))))
 (maintainer: "Matthew Martin <matt.a.martin@gmail.com>")
 (author: "Alex Shinn <foof@synthcode.com>")
 (homepage: "http://synthcode.com/scheme/")
 (description:
  "An R5RS hygienic pattern matcher backwards compatible with Andrew Wright's MATCH syntax.")
 (keywords: syntax)
 (license: public-domain))