1#lang racket/base
2(require racket/contract/base
3         racket/contract/combinator
4         syntax/location
5         (for-syntax racket/base
6                     racket/syntax
7                     "../private/minimatch.rkt"
8                     syntax/parse/pre
9                     syntax/parse/private/residual-ct ;; keep abs. path
10                     "../private/kws.rkt"
11                     syntax/contract))
12(provide provide-syntax-class/contract
13         syntax-class/c
14         splicing-syntax-class/c)
15
16;; FIXME:
17;;   - seems to get first-requiring-module wrong, not surprising
18;;   - extend to contracts on attributes?
19;;   - syntax-class/c etc just a made-up name, for now
20;;     (connect to dynamic syntax-classes, eventually)
21
22(define-syntaxes (syntax-class/c splicing-syntax-class/c)
23  (let ([nope
24         (lambda (stx)
25           (raise-syntax-error #f "not within `provide-syntax-class/contract form" stx))])
26    (values nope nope)))
27
28(begin-for-syntax
29 (define-struct ctcrec (mpcs mkws mkwcs opcs okws okwcs) #:prefab
30   #:omit-define-syntaxes))
31
32(begin-for-syntax
33 ;; do-one-contract : stx id stxclass ctcrec id -> stx
34 (define (do-one-contract stx scname stxclass rec pos-module-source)
35   ;; First, is the contract feasible?
36   (match (stxclass-arity stxclass)
37     [(arity minpos maxpos minkws maxkws)
38      (let* ([minpos* (length (ctcrec-mpcs rec))]
39             [maxpos* (+ minpos* (length (ctcrec-opcs rec)))]
40             [minkws* (sort (map syntax-e (ctcrec-mkws rec)) keyword<?)]
41             [maxkws* (sort (append minkws* (map syntax-e (ctcrec-okws rec))) keyword<?)])
42        (define (err msg . args)
43          (apply wrong-syntax scname msg args))
44        (unless (<= minpos minpos*)
45          (err (string-append "expected a syntax class with at most ~a "
46                              "required positional arguments, got one with ~a")
47               minpos* minpos))
48        (unless (<= maxpos* maxpos)
49          (err (string-append "expected a syntax class with at least ~a "
50                              "total positional arguments (required and optional), "
51                              "got one with ~a")
52               maxpos* maxpos))
53        (unless (null? (diff/sorted/eq minkws minkws*))
54          (err (string-append "expected a syntax class with at most the "
55                              "required keyword arguments ~a, got one with ~a")
56               (join-sep (map kw->string minkws*) "," "and")
57               (join-sep (map kw->string minkws) "," "and")))
58        (unless (null? (diff/sorted/eq maxkws* maxkws))
59          (err (string-append "expected a syntax class with at least the optional "
60                              "keyword arguments ~a, got one with ~a")
61               (join-sep (map kw->string maxkws*) "," "and")
62               (join-sep (map kw->string maxkws) "," "and")))
63        (with-syntax ([scname scname]
64                      [#s(stxclass name arity attrs parser splicing? opts inline)
65                       stxclass]
66                      [#s(ctcrec (mpc ...) (mkw ...) (mkwc ...)
67                                 (opc ...) (okw ...) (okwc ...))
68                       rec]
69                      [arity* (arity minpos* maxpos* minkws* maxkws*)]
70                      [(parser-contract contracted-parser contracted-scname)
71                       (generate-temporaries #`(contract parser #,scname))])
72          (with-syntax ([(mpc-id ...) (generate-temporaries #'(mpc ...))]
73                        [(mkwc-id ...) (generate-temporaries #'(mkwc ...))]
74                        [(opc-id ...) (generate-temporaries #'(opc ...))]
75                        [(okwc-id ...) (generate-temporaries #'(okwc ...))])
76            (with-syntax ([((mkw-c-part ...) ...) #'((mkw mkwc-id) ...)]
77                          [((okw-c-part ...) ...) #'((okw okwc-id) ...)]
78                          [((mkw-name-part ...) ...) #'((mkw ,(contract-name mkwc-id)) ...)]
79                          [((okw-name-part ...) ...) #'((okw ,(contract-name okwc-id)) ...)])
80              #`(begin
81                  (define parser-contract
82                    (let ([mpc-id mpc] ...
83                          [mkwc-id mkwc] ...
84                          [opc-id opc] ...
85                          [okwc-id okwc] ...)
86                      (rename-contract
87                       (->* (any/c any/c any/c any/c any/c any/c any/c any/c any/c
88                             mpc-id ... mkw-c-part ... ...)
89                            (okw-c-part ... ...)
90                            any)
91                       `(,(if 'splicing? 'splicing-syntax-class/c 'syntax-class/c)
92                         [,(contract-name mpc-id) ... mkw-name-part ... ...]
93                         [okw-name-part ... ...]))))
94                  (define-module-boundary-contract contracted-parser
95                    parser parser-contract #:pos-source #,pos-module-source)
96                  (define-syntax contracted-scname
97                    (make-stxclass
98                     (quote-syntax name)
99                     'arity*
100                     'attrs
101                     (quote-syntax contracted-parser)
102                     'splicing?
103                     'opts #f)) ;; must disable inlining
104                  (provide (rename-out [contracted-scname scname])))))))])))
105
106(define-syntax (provide-syntax-class/contract stx)
107
108  (define-syntax-class stxclass-ctc
109    #:description "syntax-class/c or splicing-syntax-class/c form"
110    #:literals (syntax-class/c splicing-syntax-class/c)
111    #:attributes (rec)
112    #:commit
113    (pattern ((~or syntax-class/c splicing-syntax-class/c)
114              mand:ctclist
115              (~optional opt:ctclist))
116             #:attr rec (make-ctcrec (attribute mand.pc.c)
117                                     (attribute mand.kw)
118                                     (attribute mand.kwc.c)
119                                     (or (attribute opt.pc.c) '())
120                                     (or (attribute opt.kw) '())
121                                     (or (attribute opt.kwc.c) '()))))
122
123  (define-syntax-class ctclist
124    #:attributes ([pc.c 1] [kw 1] [kwc.c 1])
125    #:commit
126    (pattern ((~or pc:expr (~seq kw:keyword kwc:expr)) ...)
127             #:with (pc.c ...) (for/list ([pc-expr (in-list (syntax->list #'(pc ...)))])
128                                 (wrap-expr/c #'contract? pc-expr))
129             #:with (kwc.c ...) (for/list ([kwc-expr (in-list (syntax->list #'(kwc ...)))])
130                                  (wrap-expr/c #'contract? kwc-expr))))
131
132  (syntax-parse stx
133    [(_ [scname c:stxclass-ctc] ...)
134     #:declare scname (static stxclass? "syntax class")
135     (parameterize ((current-syntax-context stx))
136       (with-disappeared-uses
137        #`(begin (define pos-module-source (quote-module-name))
138                 #,@(for/list ([scname (in-list (syntax->list #'(scname ...)))]
139                               [stxclass (in-list (attribute scname.value))]
140                               [rec (in-list (attribute c.rec))])
141                      (do-one-contract stx scname stxclass rec #'pos-module-source)))))]))
142
143;; Copied from unstable/contract,
144;; which requires racket/contract, not racket/contract/base
145
146;; rename-contract : contract any/c -> contract
147;; If the argument is a flat contract, so is the result.
148(define (rename-contract ctc name)
149  (let ([ctc (coerce-contract 'rename-contract ctc)])
150    (if (flat-contract? ctc)
151        (flat-named-contract name (flat-contract-predicate ctc))
152        (let* ([ctc-fo (contract-first-order ctc)]
153               [late-neg-proj (contract-late-neg-projection ctc)])
154          (make-contract #:name name
155                         #:late-neg-projection late-neg-proj
156                           #:first-order ctc-fo)))))
157