provide.rkt (7749B)
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 syntax/parse/private/minimatch 8 stxparse-info/parse/pre 9 syntax/parse/private/residual-ct ;; keep abs. path 10 syntax/parse/private/kws 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)))))