suzanne.soy/subtemplate
1
0
Fork 0
Code Issues 2 Pull Requests Actions Packages Projects Releases Wiki Activity

Simplified the generate-nested-ids contract so that it only checks the ellipsis counts, to get error messages without affecting performance too much.

Browse Source
This commit is contained in:
Georges Dupéron 2017-03-16 15:02:41 +01:00
parent d8cc62ccc1
commit 68dd58c36b
3 changed files with 57 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
private/optcontract.rkt
View File

@ -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))
(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))

39
private/template-subscripts.rkt
View File

@ -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)

22
test/test-subtemplate.rkt
View File

@ -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ᵢ …)