1#lang racket/base 2(require (for-syntax racket/base) 3 racket/match 4 syntax/stx 5 "context.rkt" 6 "stx-util.rkt") 7(provide (all-defined-out)) 8 9(module base racket/base 10 (require racket/match) 11 (provide (struct-out rep) 12 parse-pattern 13 pattern-vars) 14 15 ;; A Pattern is one of 16 ;; - Symbol 17 ;; - (cons Pattern Pattern) 18 ;; - '() 19 ;; - (rep Pattern VarList Pattern) 20 ;; A VarList is (Listof Symbol) 21 (struct rep (ph varsh pt) #:prefab) 22 23 ;; parse-pattern : Sexpr [Boolean] -> Pattern 24 (define (parse-pattern p0 [template? #f]) 25 (let loop ([p p0]) 26 (match p 27 ['() '()] 28 [(? symbol? p) p] 29 [(list* ph '... pt) 30 (unless (or (null? pt) template?) 31 (error 'parse-pattern "ellipsis with tail: ~e in ~e" p p0)) 32 (let ([ph (loop ph)] [pt (loop pt)]) 33 (rep ph (pattern-vars ph) pt))] 34 [(cons p1 p2) (cons (loop p1) (loop p2))] 35 [_ (error 'parse-pattern "bad pattern: ~e in ~e" p p0)]))) 36 37 ;; pattern-vars : Pattern -> VarList 38 (define (pattern-vars p0) 39 (let loop ([p p0]) 40 (match p 41 [(? symbol? p) (list p)] 42 [(cons p1 p2) (append (loop p1) (loop p2))] 43 ['() null] 44 [(rep ph varsh '()) varsh] 45 [(rep ph varsh pt) (append varsh (pattern-vars pt))])))) 46 47(require (for-syntax 'base) 'base) 48 49(define-syntax (quote-pattern stx) 50 (syntax-case stx () 51 [(_ p) #`(quote #,(parse-pattern (syntax->datum #'p)))])) 52 53(define-syntax (quote-template-pattern stx) 54 (syntax-case stx () 55 [(_ p) #`(quote #,(parse-pattern (syntax->datum #'p) #t))])) 56 57;; A Match is (match-result VarList MatchEnv) 58;; where MatchEnv = (Listof MatchValue) 59;; MatchValue = Stx | (Listof MatchValue) 60(struct match-result (vars vals) #:prefab) 61(define empty-match-result (match-result null null)) 62 63;; pattern-match : Pattern Stx -> Match/#f 64(define (pattern-match p0 t0) 65 (define menv 66 (let loop ([p p0] [t t0]) 67 (match p 68 [(? symbol? p) (list t)] 69 ['() (and (stx-null? t) null)] 70 [(cons p1 p2) 71 (cond [(stx-pair? t) 72 (let ([m1 (loop p1 (stx-car t))] 73 [m2 (loop p2 (stx-cdr t))]) 74 (and m1 m2 (append m1 m2)))] 75 [else #f])] 76 [(rep p* vars* '()) 77 (cond [(stx->list t) 78 => (lambda (ts) 79 (define ms (map (lambda (t) (loop p* t)) ts)) 80 (and (andmap values ms) 81 (foldr (lambda (row acc) (map cons row acc)) 82 (map (lambda (var) null) vars*) 83 ms)))] 84 [else #f])]))) 85 (and menv (match-result (pattern-vars p0) menv))) 86 87;; pattern-match-update : Match Match [Nat/#f] -> Match 88;; Updates first result with second. If index is given, then m2's vars 89;; must occur in m1's pattern in ellipsis, and m2's values replace the 90;; index-th elements rather than the whole lists. 91(define (pattern-match-update m1 m2 [index #f]) 92 (match-define (match-result vars1 vals1) m1) 93 (match-define (match-result vars2 vals2) m2) 94 (define (m2-var-index v) 95 (for/first ([var (in-list vars2)] [k (in-naturals)] #:when (eq? v var)) k)) 96 (define (list-replace xs k y) 97 (cond [(not (pair? xs)) 98 (error 'pattern-match-update "index out of range: ~s for ~e" index m1)] 99 [(zero? k) (cons y (cdr xs))] 100 [else (cons (car xs) (list-replace (cdr xs) (sub1 k) y))])) 101 (match-result vars1 102 (for/list ([var (in-list vars1)] [val1 (in-list vals1)]) 103 (cond [(m2-var-index var) 104 => (lambda (var-index2) 105 (define val2 (list-ref vals2 var-index2)) 106 (cond [index (list-replace val1 index val2)] 107 [else val2]))] 108 [else val1])))) 109 110;; pattern-template : Pattern Match -> Stx 111(define (pattern-template p0 mv) 112 (match-define (match-result vars m) mv) 113 (let outerloop ([p p0] [vars vars] [m m]) 114 (define (var-index v) 115 (or (for/first ([var (in-list vars)] [k (in-naturals)] #:when (eq? v var)) k) 116 (error 'pattern-template "unknown var: ~e in ~e" v p))) 117 (define (get-var v) (list-ref m (var-index v))) 118 (let loop ([p p]) 119 (match p 120 [(? symbol? p) (get-var p)] 121 ['() null] 122 [(cons p1 p2) (cons (loop p1) (loop p2))] 123 [(rep (? symbol? p) _ '()) (get-var p)] 124 [(rep p* vars* pt) 125 (define m* (map (lambda (v) (get-var v)) vars*)) 126 (let reploop ([m* m*]) 127 (cond [(andmap pair? m*) 128 (cons (outerloop p* vars* (map car m*)) 129 (reploop (map cdr m*)))] 130 [else (loop pt)]))])))) 131 132;; pattern-resyntax : Pattern Stx Stx -> Stx 133(define (pattern-resyntax p0 orig t0) 134 (let loop ([p p0] [orig orig] [t t0]) 135 (if (or (syntax? t) (eq? t orig)) 136 t 137 (match p 138 [(cons p1 p2) 139 (restx (cons (loop p1 (stx-car orig) (car t)) 140 (loop p2 (stx-cdr orig) (cdr t))) 141 orig)] 142 [(rep p* _ '()) 143 (let reploop ([orig orig] [t t]) 144 (cond [(syntax? t) t] 145 [(stx-pair? t) 146 (restx (cons (loop p* (stx-car orig) (stx-car t)) 147 (reploop (stx-cdr orig) (stx-cdr t))) 148 orig)] 149 [else (restx t orig)]))] 150 [_ (restx t orig)])))) 151 152;; pattern-replace : Pattern Stx Pattern Stx -> Stx 153;; Like (with-syntax ([p1 stx1]) (with-syntax ([p2 stx2]) (syntax p1))). 154(define (pattern-replace p1 stx1 p2 stx2 #:resyntax? resyntax?) 155 (define m1 (pattern-match p1 stx1)) 156 (define m2 (pattern-match p2 stx2)) 157 (define m-out (pattern-match-update m1 m2)) 158 (define stx-out (pattern-template p1 m-out)) 159 (if resyntax? (pattern-resyntax p1 stx1 stx-out) stx-out)) 160 161;; subpattern-path : Pattern Symbol [Boolean] -> (U Path (vector Path Path)) 162(define (subpattern-path p0 hole [rep? #f]) 163 (define (outerloop p repb) 164 (let loop ([p p]) 165 (match p 166 [(cons p1 p2) 167 (cond [(loop p1) => path-add-car] 168 [(loop p2) => path-add-cdr] 169 [else #f])] 170 [(rep p* _ '()) 171 (cond [(outerloop p* #f) 172 => (lambda (subpath) 173 (unless repb 174 (error 'subpattern->path "hole has ellipses: ~s, ~s" hole p0)) 175 (set-box! repb subpath) 176 (empty-path))] 177 [else #f])] 178 [(== hole) 179 (when repb 180 (error 'subpattern->path "hole does not have ellipses: ~s, ~s" hole p0)) 181 (empty-path)] 182 [else #f]))) 183 (let ([repb (and rep? (box #f))]) 184 (cond [(outerloop p0 repb) 185 => (lambda (path) (if repb (vector path (unbox repb)) path))] 186 [(error 'subpattern->path "hole not found: ~s, ~s" hole p0)]))) 187