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