commit 68dd58c36b2b77dd8b0c02136858e2126d9bbb0f
parent d8cc62ccc17efe72b0f868bf7aaeb1b90f1f9c31
Author: Georges Dupéron <georges.duperon@gmail.com>
Date: Thu, 16 Mar 2017 15:02:41 +0100
Simplified the generate-nested-ids contract so that it only checks the ellipsis counts, to get error messages without affecting performance too much.
Diffstat:
3 files changed, 58 insertions(+), 21 deletions(-)
diff --git a/private/optcontract.rkt b/private/optcontract.rkt
@@ -1,15 +1,21 @@
#lang racket
-(require (rename-in racket/contract
- [define/contract define/contract/always]))
-
(provide (except-out (all-from-out racket/contract)
define-struct/contract
;define/contract
provide/contract
invariant-assertion)
define/contract
- define/contract/always)
+ define/contract/always
+ define/contract/alt)
+
+(require (rename-in racket/contract
+ [define/contract define/contract/always]))
(define-syntax-rule (define/contract sig c . rest)
- (define sig . rest))
-\ No newline at end of file
+ (define sig . rest))
+
+;; The alt-code is executed in the body of the function when the contract is
+;; disabled:
+(define-syntax-rule (define/contract/alt sig c alt-code . rest)
+ (define sig alt-code . rest))
+\ No newline at end of file
diff --git a/private/template-subscripts.rkt b/private/template-subscripts.rkt
@@ -241,8 +241,23 @@
(define formattable/c (or/c number? string? symbol? bytes?))
-(define/contract/always
- (generate-nested-ids depth bound binder₀ format l* attribute-names whole-form)
+(define (generate-nested-ids-check-ellipsis-match-count
+ l* depth attribute-names whole-form bound)
+ (if ((ellipsis-count/c depth) l*)
+ #t
+ (raise-syntax-error
+ (syntax-case whole-form ()
+ [(self . _) (syntax-e #'self)]
+ [_ 'subtemplate])
+ "incompatible ellipsis match counts for subscripted variables:"
+ whole-form
+ bound
+ attribute-names)))
+
+(module+ test-private
+ (provide generate-nested-ids))
+
+(define generate-nested-ids-full-contract
(->i {[depth exact-nonnegative-integer?]
[bound identifier?]
[binder₀ identifier?]
@@ -252,21 +267,17 @@
(λ (a) (= (length l*) (length a))))]
[whole-form syntax?]}
#:pre (l* depth attribute-names whole-form bound)
- (if ((ellipsis-count/c depth) l*)
- #t
- (raise-syntax-error
- (syntax-case whole-form ()
- [(self . _) (syntax-e #'self)]
- [_ 'subtemplate])
- "incompatible ellipsis match counts for subscripted variables:"
- whole-form
- bound
- attribute-names))
+ (generate-nested-ids-check-ellipsis-match-count
+ l* depth attribute-names whole-form bound)
{result (depth l*)
(and/c (attribute-val/c depth identifier?)
- (λ (r) ((ellipsis-count/c depth) (cons r l*))))})
+ (λ (r) ((ellipsis-count/c depth) (cons r l*))))}))
-
+(define/contract/alt
+ (generate-nested-ids depth bound binder₀ format l* attribute-names whole-form)
+ generate-nested-ids-full-contract
+ (generate-nested-ids-check-ellipsis-match-count
+ l* depth attribute-names whole-form bound)
(define (gen bottom*)
(define v
(let ([vs (filter-map (λ (v)
diff --git a/test/test-subtemplate.rkt b/test/test-subtemplate.rkt
@@ -357,7 +357,27 @@
(syntax-case #'([a b c] [d]) ()
[([xᵢ …] [pᵢ …])
(quasisubtemplate ([xᵢ …] [pᵢ …]))]))
- '([a b c] [d])))
+ '([a b c] [d]))
+
+ (require (submod "../private/template-subscripts.rkt" test-private))
+ (check-exn #rx"incompatible ellipsis match counts for subscripted variables"
+ (λ ()
+ (generate-nested-ids 1
+ #'a
+ #'b
+ (λ (x) "fmt")
+ '((foo bar) (baz))
+ (list #'x #'y)
+ #'(whole))))
+ (check-equal? (map syntax-e
+ (generate-nested-ids 1
+ #'a
+ #'b
+ (λ (x) "fmt")
+ '((foo bar) (baz quux))
+ (list #'x #'y)
+ #'(whole)))
+ '(fmt fmt)))
(syntax-parse (syntax-parse #'(a b c)
[(xᵢ …)
