1#lang racket/base
2(require racket/contract/base
3         racket/dict
4         syntax/private/id-table
5         racket/syntax
6         syntax/parse/private/residual-ct ;; keep abs. path
7         "minimatch.rkt"
8         "kws.rkt")
9;; from residual.rkt
10(provide (struct-out stxclass)
11         (struct-out conventions)
12         (struct-out literalset)
13         (struct-out eh-alternative-set)
14         (struct-out eh-alternative))
15;; from here
16(provide stxclass/s?
17         stxclass/h?
18         (struct-out rhs)
19         (struct-out variant))
20
21(define (stxclass/s? x)
22  (and (stxclass? x) (not (stxclass-splicing? x))))
23(define (stxclass/h? x)
24  (and (stxclass? x) (stxclass-splicing? x)))
25
26;; An RHS is #s(rhs SAttrs Bool Stx/#f Variants Stxs Bool Bool)
27(define-struct rhs
28  (attrs        ;; (Listof Sattr)
29   transparent? ;; Bool
30   description  ;; Syntax/#f
31   variants     ;; (Listof Variant)
32   definitions  ;; (Listof Stx), aux definitions from txlifts, local conventions?, etc
33   commit?      ;; Bool
34   delimit-cut? ;; Bool
35   ) #:prefab)
36
37;; A Variant is (variant Stx SAttrs Pattern Stxs)
38(define-struct variant
39  (ostx         ;; Stx
40   attrs        ;; (Listof SAttr)
41   pattern      ;; Pattern
42   definitions  ;; (Listof Stx)
43   ) #:prefab)
44
45;; Environments
46
47#|
48DeclEnv =
49  (make-declenv immutable-bound-id-mapping[id => DeclEntry]
50                (listof ConventionRule))
51
52DeclEntry =
53- (den:lit Id Id Stx Stx)
54- (den:datum-lit Id Symbol)
55- (den:class Id Id Arguments)
56- (den:magic-class Id Id Arguments Stx)
57- (den:delayed Id Id)
58
59Arguments is defined in rep-patterns.rkt
60
61A DeclEnv is built up in stages:
62  1) syntax-parse (or define-syntax-class) directives
63     #:literals -> den:lit
64     #:datum-literals -> den:datum-lit
65     #:local-conventions -> den:class
66     #:conventions -> den:delayed
67     #:literal-sets -> den:lit
68  2) pattern directives
69     #:declare -> den:magic-class
70  3) create-aux-def creates aux parser defs
71     den:class -> den:delayed
72
73== Scoping ==
74
75A #:declare directive results in a den:magic-class entry, which
76indicates that the pattern variable's syntax class arguments (if any)
77have "magical scoping": they are evaluated in the scope where the
78pattern variable occurs. If the variable occurs multiple times, the
79expressions are duplicated, and may be evaluated in different scopes.
80|#
81
82(define-struct declenv (table conventions))
83
84(define-struct den:class (name class argu))
85(define-struct den:magic-class (name class argu role))
86;; and from residual.rkt:
87;;  (define-struct den:lit (internal external input-phase lit-phase))
88;;  (define-struct den:datum-lit (internal external))
89;;  (define-struct den:delayed (parser class))
90
91(define (new-declenv literals #:conventions [conventions null])
92  (let* ([table (make-immutable-bound-id-table)]
93         [table (for/fold ([table table]) ([literal (in-list literals)])
94                  (let ([id (cond [(den:lit? literal) (den:lit-internal literal)]
95                                  [(den:datum-lit? literal) (den:datum-lit-internal literal)])])
96                    ;;(eprintf ">> added ~e\n" id)
97                    (bound-id-table-set table id literal)))])
98    (make-declenv table conventions)))
99
100(define (declenv-lookup env id)
101  (bound-id-table-ref (declenv-table env) id #f))
102
103(define (declenv-apply-conventions env id)
104  (conventions-lookup (declenv-conventions env) id))
105
106(define (declenv-check-unbound env id [stxclass-name #f]
107                               #:blame-declare? [blame-declare? #f])
108  ;; Order goes: literals, pattern, declares
109  ;; So blame-declare? only applies to stxclass declares
110  (let ([val (declenv-lookup env id)])
111    (match val
112      [(den:lit _i _e _ip _lp)
113       (wrong-syntax id "identifier previously declared as literal")]
114      [(den:datum-lit _i _e)
115       (wrong-syntax id "identifier previously declared as literal")]
116      [(den:magic-class name _c _a _r)
117       (if (and blame-declare? stxclass-name)
118           (wrong-syntax name
119                         "identifier previously declared with syntax class ~a"
120                         stxclass-name)
121           (wrong-syntax (if blame-declare? name id)
122                         "identifier previously declared"))]
123      [(den:class name _c _a)
124       (if (and blame-declare? stxclass-name)
125           (wrong-syntax name
126                         "identifier previously declared with syntax class ~a"
127                         stxclass-name)
128           (wrong-syntax (if blame-declare? name id)
129                         "identifier previously declared"))]
130      ['#f (void)])))
131
132(define (declenv-put-stxclass env id stxclass-name argu [role #f])
133  (declenv-check-unbound env id)
134  (make-declenv
135   (bound-id-table-set (declenv-table env) id
136                       (den:magic-class id stxclass-name argu role))
137   (declenv-conventions env)))
138
139;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a
140;;                    -> (values DeclEnv a)
141(define (declenv-update/fold env0 f acc0)
142  (define-values (acc1 rules1)
143    (for/fold ([acc acc0] [newrules null])
144        ([rule (in-list (declenv-conventions env0))])
145      (let-values ([(val acc) (f (car rule) (cadr rule) acc)])
146        (values acc (cons (list (car rule) val) newrules)))))
147  (define-values (acc2 table2)
148    (for/fold ([acc acc1] [table (make-immutable-bound-id-table)])
149        ([(k v) (in-dict (declenv-table env0))])
150      (let-values ([(val acc) (f k v acc)])
151        (values acc (bound-id-table-set table k val)))))
152  (values (make-declenv table2 (reverse rules1))
153          acc2))
154
155;; returns ids in domain of env but not in given list
156(define (declenv-domain-difference env ids)
157  (define idbm (make-bound-id-table))
158  (for ([id (in-list ids)]) (bound-id-table-set! idbm id #t))
159  (for/list ([(k v) (in-dict (declenv-table env))]
160             #:when (or (den:class? v) (den:magic-class? v))
161             #:unless (bound-id-table-ref idbm k #f))
162    k))
163
164;; Conventions = (listof (list regexp DeclEntry))
165
166(define (conventions-lookup conventions id)
167  (let ([sym (symbol->string (syntax-e id))])
168    (for/or ([c (in-list conventions)])
169      (and (regexp-match? (car c) sym) (cadr c)))))
170
171;; Contracts
172
173(define DeclEnv/c declenv?)
174
175(define DeclEntry/c
176  (or/c den:lit? den:datum-lit? den:class? den:magic-class? den:delayed?))
177
178(provide (struct-out den:class)
179         (struct-out den:magic-class)
180         ;; from residual.rkt:
181         (struct-out den:lit)
182         (struct-out den:datum-lit)
183         (struct-out den:delayed))
184
185(provide/contract
186 [DeclEnv/c contract?]
187 [DeclEntry/c contract?]
188
189 [new-declenv
190  (->* [(listof (or/c den:lit? den:datum-lit?))]
191       [#:conventions list?]
192       DeclEnv/c)]
193 [declenv-lookup
194  (-> DeclEnv/c identifier? any)]
195 [declenv-apply-conventions
196  (-> DeclEnv/c identifier? any)]
197 [declenv-put-stxclass
198  (-> DeclEnv/c identifier? identifier? arguments? (or/c syntax? #f)
199      DeclEnv/c)]
200 [declenv-domain-difference
201  (-> DeclEnv/c (listof identifier?)
202      (listof identifier?))]
203 [declenv-update/fold
204  (-> DeclEnv/c
205      (-> (or/c identifier? regexp?) DeclEntry/c any/c (values DeclEntry/c any/c))
206      any/c
207      (values DeclEnv/c any/c))]
208 [declenv-check-unbound
209  (->* [DeclEnv/c identifier?] [symbol? #:blame-declare? boolean?] any)]
210
211 [get-stxclass
212  (->* [identifier?] [boolean?] (or/c stxclass? #f))]
213 [check-stxclass-arity
214  (-> stxclass? syntax? exact-nonnegative-integer? (listof keyword?) any)]
215 [get-stxclass/check-arity
216  (-> identifier? syntax? exact-nonnegative-integer? (listof keyword?)
217      stxclass?)])
218
219;; get-stxclass : Identifier [Boolean] -> stxclass/#f
220;; Stxclasses are primarily bound by env / syntax-local-value, but a few
221;; are attached to existing bindings via alt-stxclass-mapping.
222(define (get-stxclass id [allow-undef? #f])
223  (let loop ([id id]
224             [prev-ids '()])
225    (cond [(syntax-local-value/record id stxclass?) => values]
226          [(syntax-local-value/record id has-stxclass-prop?)
227           => (lambda (val)
228                (define prop-val (stxclass-prop-ref val))
229                (define prop-id (if (identifier? prop-val) prop-val (prop-val val)))
230                (loop prop-id (cons id prev-ids)))]
231          [(assoc id (unbox alt-stxclass-mapping) free-identifier=?) => cdr]
232          [allow-undef? #f]
233          [else (wrong-syntax id #:extra prev-ids "not defined as syntax class")])))
234
235;; check-stxclass-arity : stxclass Syntax Nat (Listof Keyword) -> Void
236(define (check-stxclass-arity sc stx pos-count keywords)
237  (check-arity (stxclass-arity sc) pos-count keywords
238               (lambda (msg) (raise-syntax-error #f msg stx))))
239
240(define (get-stxclass/check-arity id stx pos-count keywords)
241  (define sc (get-stxclass id))
242  (check-stxclass-arity sc stx pos-count keywords)
243  sc)
244
245;; ----
246
247(provide get-eh-alternative-set)
248
249(define (get-eh-alternative-set id)
250  (let ([v (syntax-local-value id (lambda () #f))])
251    (unless (eh-alternative-set? v)
252      (wrong-syntax id "not defined as an eh-alternative-set"))
253    v))
254