1#lang racket/base
2(require syntax/parse/private/residual-ct ;; keep abs. path
3         racket/contract/base
4         syntax/private/id-table
5         racket/syntax
6         "make.rkt")
7
8#|
9An IAttr is (make-attr identifier number boolean)
10An SAttr is (make-attr symbol number boolean)
11
12The number is the ellipsis nesting depth. The boolean is true iff the
13attr is guaranteed to be bound to a value which is a syntax object (or
14a list^depth of syntax objects).
15|#
16
17#|
18SAttr lists are always stored in sorted order, to make comparison
19of signatures easier for reified syntax-classes.
20|#
21
22(define (iattr? a)
23  (and (attr? a) (identifier? (attr-name a))))
24
25(define (sattr? a)
26  (and (attr? a) (symbol? (attr-name a))))
27
28;; increase-depth : Attr -> Attr
29(define (increase-depth x)
30  (make attr (attr-name x) (add1 (attr-depth x)) (attr-syntax? x)))
31
32(provide/contract
33 [iattr? (any/c . -> . boolean?)]
34 [sattr? (any/c . -> . boolean?)]
35
36 [increase-depth
37  (-> attr? attr?)]
38 [attr-make-uncertain
39  (-> attr? attr?)]
40
41 ;; IAttr operations
42 [append-iattrs
43  (-> (listof (listof iattr?))
44      (listof iattr?))]
45 [union-iattrs
46  (-> (listof (listof iattr?))
47      (listof iattr?))]
48 [reorder-iattrs
49  (-> (listof sattr?) (listof iattr?)
50      (listof iattr?))]
51
52 ;; SAttr operations
53 [iattr->sattr
54  (-> iattr?
55      sattr?)]
56 [iattrs->sattrs
57  (-> (listof iattr?)
58      (listof sattr?))]
59 [sort-sattrs
60  (-> (listof sattr?)
61      (listof sattr?))]
62
63 [intersect-sattrss
64  (-> (listof (listof sattr?))
65      (listof sattr?))]
66
67 [check-iattrs-subset
68  (-> (listof iattr?)
69      (listof iattr?)
70      (or/c syntax? false/c)
71      any)])
72
73;; IAttr operations
74
75;; append-iattrs : (listof (listof IAttr)) -> (listof IAttr)
76;; Assumes that each sublist is duplicate-free.
77(define (append-iattrs attrss)
78  (cond [(null? attrss) null]
79        [(null? (cdr attrss)) (car attrss)]
80        [else
81         (let* ([all (apply append attrss)]
82                [names (map attr-name all)]
83                [dup (and (pair? names) (check-duplicate-identifier names))])
84           (when dup (wrong-syntax dup "duplicate attribute"))
85           all)]))
86
87;; union-iattrs : (listof (listof IAttr)) -> (listof IAttr)
88(define (union-iattrs attrss)
89  (define count-t (make-bound-id-table))
90  (define attr-t (make-bound-id-table))
91  (define list-count (length attrss))
92  (define attr-keys null)
93  (for* ([attrs (in-list attrss)] [attr (in-list attrs)])
94    (define name (attr-name attr))
95    (define prev (bound-id-table-ref attr-t name #f))
96    (unless prev (set! attr-keys (cons name attr-keys)))
97    (bound-id-table-set! attr-t name (join-attrs attr prev))
98    (let ([pc (bound-id-table-ref count-t name 0)])
99      (bound-id-table-set! count-t name (add1 pc))))
100  (for/list ([k (in-list attr-keys)])
101    (define a (bound-id-table-ref attr-t k))
102    (if (= (bound-id-table-ref count-t (attr-name a)) list-count)
103        a
104        (attr-make-uncertain a))))
105
106;; join-attrs : Attr Attr/#f -> Attr
107;; Works with both IAttrs and SAttrs.
108;; Assumes attrs have same name.
109(define (join-attrs a b)
110  (if (and a b)
111      (proper-join-attrs a b)
112      (or a b)))
113
114(define (proper-join-attrs a b)
115  (let ([aname (attr-name a)])
116    (unless (equal? (attr-depth a) (attr-depth b))
117      (wrong-syntax (and (syntax? aname) aname)
118                    "attribute '~a' occurs with different nesting depth"
119                    (if (syntax? aname) (syntax-e aname) aname)))
120    (make attr aname (attr-depth a) (and (attr-syntax? a) (attr-syntax? b)))))
121
122(define (attr-make-uncertain a)
123  (make attr (attr-name a) (attr-depth a) #f))
124
125(define (iattr->sattr a)
126  (let ([name (attr-name a)]
127        [depth (attr-depth a)]
128        [syntax? (attr-syntax? a)])
129     (make attr (syntax-e name) depth syntax?)))
130
131(define (iattrs->sattrs as)
132  (sort-sattrs (map iattr->sattr as)))
133
134(define (sort-sattrs as)
135  (sort as string<?
136        #:key (lambda (a) (symbol->string (attr-name a)))
137        #:cache-keys? #t))
138
139;; intersect-sattrss : (listof (listof SAttr)) -> (listof SAttr)
140;; FIXME: rely on sorted inputs, simplify algorithm and avoid second sort?
141(define (intersect-sattrss attrss)
142  (cond [(null? attrss) null]
143        [else
144         (let* ([namess (map (lambda (attrs) (map attr-name attrs)) attrss)]
145                [names (filter (lambda (s)
146                                 (andmap (lambda (names) (memq s names))
147                                         (cdr namess)))
148                               (car namess))]
149                [ht (make-hasheq)]
150                [put (lambda (attr) (hash-set! ht (attr-name attr) attr))]
151                [fetch-like (lambda (attr) (hash-ref ht (attr-name attr) #f))])
152           (for* ([attrs (in-list attrss)]
153                  [attr (in-list attrs)]
154                  #:when (memq (attr-name attr) names))
155             (put (join-attrs attr (fetch-like attr))))
156           (sort-sattrs (hash-map ht (lambda (k v) v))))]))
157
158;; reorder-iattrs : (listof SAttr) (listof IAttr) -> (listof IAttr)
159;; Reorders iattrs (and restricts) based on relsattrs
160;; If a relsattr is not found, or if depth or contents mismatches, raises error.
161(define (reorder-iattrs relsattrs iattrs)
162  (let ([ht (make-hasheq)])
163    (for ([iattr (in-list iattrs)])
164      (let ([remap-name (syntax-e (attr-name iattr))])
165        (hash-set! ht remap-name iattr)))
166    (let loop ([relsattrs relsattrs])
167      (if (null? relsattrs)
168          null
169          (let ([sattr (car relsattrs)]
170                [rest (cdr relsattrs)])
171            (let ([iattr (hash-ref ht (attr-name sattr) #f)])
172              (check-iattr-satisfies-sattr iattr sattr)
173              (cons iattr (loop rest))))))))
174
175(define (check-iattr-satisfies-sattr iattr sattr)
176  (unless iattr
177    (wrong-syntax #f "required attribute is not defined: ~s" (attr-name sattr)))
178  (unless (= (attr-depth iattr) (attr-depth sattr))
179    (wrong-syntax (attr-name iattr)
180                  "attribute has wrong depth (expected ~s, found ~s)"
181                  (attr-depth sattr) (attr-depth iattr)))
182  (when (and (attr-syntax? sattr) (not (attr-syntax? iattr)))
183    (wrong-syntax (attr-name iattr)
184                  "attribute may not be bound to syntax: ~s"
185                  (attr-name sattr))))
186
187;; check-iattrs-subset : (listof IAttr) (listof IAttr) stx -> void
188(define (check-iattrs-subset little big ctx)
189  (define big-t (make-bound-id-table))
190  (for ([a (in-list big)])
191    (bound-id-table-set! big-t (attr-name a) #t))
192  (for ([a (in-list little)])
193    (unless (bound-id-table-ref big-t (attr-name a) #f)
194      (raise-syntax-error #f
195                          "attribute bound in defaults but not in pattern"
196                          ctx
197                          (attr-name a)))))
198