syntax/parse:
tweaked error selection algorithm added tests svn: r16533
This commit is contained in:
Ryan Culpepper
parent
f3ae0f1875
commit
0feac0f636
|
|
@ -6,77 +6,6 @@
|
|||
"runtime.ss"))
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; Frontiers
|
||||
|
||||
;; A FrontierContextExpr (FCE) is one of
|
||||
;; - (make-fce Id (listof FrontierIndexExpr))
|
||||
;; A FrontierIndexExpr is
|
||||
;; - #'(+ Number expr ...)
|
||||
(define-struct fce (stx indexes) #:prefab)
|
||||
|
||||
(define (empty-frontier x)
|
||||
(make-fce x (list #'(+ 0))))
|
||||
|
||||
(define (done-frontier x)
|
||||
(make-fce x (list #'(+ 0) #'(+ +inf.0))))
|
||||
|
||||
(define (frontier:add-car fc x)
|
||||
(make-fce x (cons #'(+ 0) (fce-indexes fc))))
|
||||
|
||||
(define (frontier:add-cdr fc)
|
||||
(define (fi:add1 fi)
|
||||
(syntax-case fi (+)
|
||||
[(+ n . rest)
|
||||
#`(+ #,(add1 (syntax-e #'n)) . rest)]))
|
||||
(make-fce (fce-stx fc)
|
||||
(cons (fi:add1 (stx-car (fce-indexes fc)))
|
||||
(stx-cdr (fce-indexes fc)))))
|
||||
|
||||
(define (frontier:add-index fc expr)
|
||||
(define (fi:add-index fi expr)
|
||||
(syntax-case fi (+)
|
||||
[(+ n . rest)
|
||||
#`(+ n #,expr . rest)]))
|
||||
(make-fce (fce-stx fc)
|
||||
(cons (fi:add-index (stx-car (fce-indexes fc)) expr)
|
||||
(stx-cdr (fce-indexes fc)))))
|
||||
|
||||
(define (frontier:add-unvector fc x)
|
||||
(frontier:add-car fc x))
|
||||
(define (frontier:add-unbox fc x)
|
||||
(frontier:add-car fc x))
|
||||
(define (frontier:add-unpstruct fc x)
|
||||
(frontier:add-car fc x))
|
||||
|
||||
(define (frontier:add-subparse fc x)
|
||||
(frontier:add-car
|
||||
(frontier:add-index (frontier:add-car fc x) +inf.0)
|
||||
x))
|
||||
|
||||
;; A DynamicFrontierContext (DFC) is a list of numbers.
|
||||
;; More operations on DFCs in runtime.ss
|
||||
|
||||
(define (frontier->dfc-expr fc)
|
||||
(define (fi->qq-part fi)
|
||||
(syntax-case fi (+)
|
||||
[(+ n)
|
||||
#'n]
|
||||
[expr #`(unquote expr)]))
|
||||
(let ([fis (reverse (stx->list (fce-indexes fc)))])
|
||||
(with-syntax ([(part ...) (map fi->qq-part fis)])
|
||||
#`(quasiquote (part ...)))))
|
||||
|
||||
(define (frontier->fstx-expr fc)
|
||||
(fce-stx fc))
|
||||
|
||||
(define (frontier->index-expr fc)
|
||||
(syntax-case fc ()
|
||||
[#s(fce stx (index0 index ...))
|
||||
#'index0]))
|
||||
|
||||
;; --------
|
||||
|
||||
|
||||
(define (get-kind kind)
|
||||
(syntax-case kind ()
|
||||
[#:pair pairK]
|
||||
|
|
@ -88,11 +17,10 @@
|
|||
(and xkey (equal? xkey (quote key)))))
|
||||
(list (lambda (s d)
|
||||
#`(datum->syntax #,s (cdr (vector->list (struct->vector #,d))) #,s)))
|
||||
(list (lambda (fc x)
|
||||
(frontier:add-unpstruct fc x))))]))
|
||||
(list #'dfc-add-unpstruct))]))
|
||||
|
||||
;; A Kind is
|
||||
;; (make-kind id (listof (id id -> stx)) (listof (FCE id -> FCE)))
|
||||
;; (make-kind id (listof (id id -> stx)) (listof expr))
|
||||
|
||||
(define-struct kind (predicate selectors frontier-procs) #:transparent)
|
||||
|
||||
|
|
@ -100,16 +28,16 @@
|
|||
(make-kind #'pair?
|
||||
(list (lambda (s d) #`(car #,d))
|
||||
(lambda (s d) #`(datum->syntax #,s (cdr #,d) #,s)))
|
||||
(list (lambda (fc x) (frontier:add-car fc x))
|
||||
(lambda (fc x) (frontier:add-cdr fc)))))
|
||||
(list #'dfc-add-car
|
||||
#'dfc-add-cdr)))
|
||||
|
||||
(define vectorK
|
||||
(make-kind #'vector?
|
||||
(list (lambda (s d)
|
||||
#`(datum->syntax #,s (vector->list #,d) #,s)))
|
||||
(list (lambda (fc x) (frontier:add-unvector fc x)))))
|
||||
(list #'dfc-add-unvector)))
|
||||
|
||||
(define boxK
|
||||
(make-kind #'box?
|
||||
(list (lambda (s d) #`(unbox #,d)))
|
||||
(list (lambda (fc x) (frontier:add-unbox fc x)))))
|
||||
(list #'dfc-add-unbox)))
|
||||
|
|
|
|||
|
|
@ -36,7 +36,7 @@
|
|||
kernel-literals)
|
||||
|
||||
(define-syntax-rule (define-pred-stxclass name pred)
|
||||
(define-syntax-class name #:attributes ()
|
||||
(define-syntax-class name #:attributes () #:opaque
|
||||
(pattern x
|
||||
#:fail-unless (pred (syntax-e #'x)) #f)))
|
||||
|
||||
|
|
|
|||
|
|
@ -36,14 +36,13 @@
|
|||
|
||||
;; ----
|
||||
|
||||
;; An FCE is expr[DFC]
|
||||
|
||||
;; (fail expr #:expect expr #:fce FCE) : expr
|
||||
(define-syntax (fail stx)
|
||||
(syntax-case stx ()
|
||||
[(fail x #:expect p #:fce fce)
|
||||
(let ([fc-expr (frontier->dfc-expr (wash #'fce))]
|
||||
[fstx-expr (frontier->fstx-expr (wash #'fce))])
|
||||
#`(enclosing-fail
|
||||
(make-failure x #,fc-expr #,fstx-expr p)))]))
|
||||
#'(enclosing-fail (make-failure x fce p))]))
|
||||
|
||||
;; (parse:rhs RHS (SAttr ...) (id ...) id boolean)
|
||||
;; : expr[(values ParseFunction DescriptionFunction)]
|
||||
|
|
@ -73,15 +72,13 @@
|
|||
(define-syntax (parse:variant stx)
|
||||
(syntax-case stx ()
|
||||
[(parse:variant x relsattrs variant #f)
|
||||
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant]
|
||||
[fc (empty-frontier #'x)])
|
||||
#`(let ()
|
||||
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant])
|
||||
#`(let ([fc (dfc-empty x)])
|
||||
def ...
|
||||
(parse:S x fc pattern (variant-success x relsattrs variant ()))))]
|
||||
[(parse:variant x relsattrs variant #t)
|
||||
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant]
|
||||
[fc (empty-frontier #'x)])
|
||||
#`(let ()
|
||||
(with-syntax ([#s(variant _ _ pattern _ (def ...)) #'variant])
|
||||
#`(let ([fc (dfc-empty x)])
|
||||
def ...
|
||||
(parse:H x fc pattern rest index
|
||||
(variant-success x relsattrs variant (rest index)))))]))
|
||||
|
|
@ -104,17 +101,19 @@
|
|||
[(convert-sides x (side0 . sides) (k iattrs . kargs))
|
||||
(syntax-case #'side0 ()
|
||||
[#s(clause:fail condition message)
|
||||
#`(let ([c (without-fails condition)])
|
||||
#`(let* ([c (without-fails condition)]
|
||||
[fc (dfc-add-post (dfc-empty x) (if (syntax? c) c x))])
|
||||
(if c
|
||||
(fail (if (syntax? c) c x)
|
||||
#:expect (expectation-of-message message)
|
||||
#:fce #,(frontier:add-subparse (done-frontier #'x) #'(if (syntax? c) c x)))
|
||||
#:fce fc)
|
||||
(convert-sides x sides (k iattrs . kargs))))]
|
||||
[#s(clause:with pattern expr (def ...))
|
||||
(with-syntax ([(p-iattr ...) (pattern-attrs (wash #'pattern))])
|
||||
#`(let ([y (datum->syntax #f (without-fails expr))])
|
||||
#`(let* ([y (datum->syntax #f (without-fails expr))]
|
||||
[fc (dfc-add-post (dfc-empty x) y)])
|
||||
def ...
|
||||
(parse:S y #,(done-frontier #'x) pattern
|
||||
(parse:S y fc pattern
|
||||
(convert-sides x sides
|
||||
(k (p-iattr ... . iattrs) . kargs)))))]
|
||||
[#s(clause:attr a expr)
|
||||
|
|
@ -156,11 +155,10 @@
|
|||
#:decls decls0
|
||||
#:context #'ctx)])
|
||||
(with-syntax ([rest rest]
|
||||
[fc (empty-frontier #'x)]
|
||||
[pattern
|
||||
(parse-whole-pattern #'p decls2 #:context #'ctx)]
|
||||
[(local-def ...) defs2])
|
||||
#`(let ()
|
||||
#`(let ([fc (dfc-empty x)])
|
||||
local-def ...
|
||||
(parse:S x fc pattern
|
||||
(convert-sides x #,sides
|
||||
|
|
@ -194,9 +192,9 @@
|
|||
(syntax-case stx ()
|
||||
[(parse:S x fc pattern0 k)
|
||||
(syntax-case #'pattern0 ()
|
||||
[#s(internal-rest-pattern rest index index0)
|
||||
[#s(internal-rest-pattern rest rest-fc)
|
||||
#`(let ([rest x]
|
||||
[index (- #,(frontier->index-expr (wash #'fc)) index0)])
|
||||
[rest-fc fc])
|
||||
k)]
|
||||
[#s(pat:name attrs pattern (name ...))
|
||||
#`(let-attributes ([#s(attr name 0 #t) x] ...)
|
||||
|
|
@ -231,8 +229,8 @@
|
|||
[#s(pat:ghost attrs ghost subpattern)
|
||||
#'(parse:G x fc ghost (parse:S x fc subpattern k))]
|
||||
[#s(pat:head attrs head tail)
|
||||
#`(parse:H x fc head rest index
|
||||
(parse:S rest #,(frontier:add-index (wash #'fc) #'index) tail k))]
|
||||
#`(parse:H x fc head rest rest-fc
|
||||
(parse:S rest rest-fc tail k))]
|
||||
[#s(pat:dots attrs head tail)
|
||||
#`(parse:dots x fc head tail k)]
|
||||
[#s(pat:and attrs subpatterns)
|
||||
|
|
@ -258,17 +256,16 @@
|
|||
(let ([kind (get-kind (wash #'kind0))])
|
||||
(with-syntax ([(part ...) (generate-temporaries (kind-selectors kind))])
|
||||
(with-syntax ([predicate (kind-predicate kind)]
|
||||
[(part-fc ...)
|
||||
(for/list ([fproc (kind-frontier-procs kind)]
|
||||
[part-var (syntax->list #'(part ...))])
|
||||
(fproc (wash #'fc) part-var))]
|
||||
[(part-fc ...) (generate-temporaries #'(part ...))]
|
||||
[(part-fc-proc ...) (kind-frontier-procs kind)]
|
||||
[(part-expr ...)
|
||||
(for/list ([selector (kind-selectors kind)])
|
||||
(selector #'x #'datum))])
|
||||
#`(let ([datum (syntax-e x)])
|
||||
(if (predicate datum)
|
||||
(let ([part part-expr] ...)
|
||||
(parse:S* (part ...) (part-fc ...) (part-pattern ...) k))
|
||||
(let ([part-fc (part-fc-proc fc part)] ...)
|
||||
(parse:S* (part ...) (part-fc ...) (part-pattern ...) k)))
|
||||
(fail x
|
||||
#:expect (expectation pattern0)
|
||||
#:fce fc))))))]
|
||||
|
|
@ -280,10 +277,11 @@
|
|||
#:expect (expectation-of-thing description transparent? failure)
|
||||
#:fce fc))
|
||||
(with-enclosing-fail* new-fail
|
||||
(parse:S x #,(empty-frontier #'x) pattern
|
||||
(let ([new-fc (dfc-empty x)])
|
||||
(parse:S x new-fc pattern
|
||||
(with-enclosing-cut-fail previous-cut-fail
|
||||
(with-enclosing-fail previous-fail
|
||||
k)))))])]))
|
||||
k))))))])]))
|
||||
|
||||
;; (parse:S* (id ...) (FCE ...) (SinglePattern ...) expr) : expr
|
||||
(define-syntax parse:S*
|
||||
|
|
@ -326,16 +324,17 @@
|
|||
[#s(ghost:bind _ clauses)
|
||||
#`(convert-sides x clauses (clause-success () k))]
|
||||
[#s(ghost:fail _ condition message)
|
||||
#`(let ([c (without-fails condition)])
|
||||
#`(let* ([c (without-fails condition)]
|
||||
[fc* (dfc-add-post fc (if (syntax? c) c x))])
|
||||
(if c
|
||||
(fail (if (syntax? c) c x)
|
||||
#:expect (expectation pattern0)
|
||||
#:fce #,(frontier:add-subparse (wash #'fc) #'(if (syntax? c) c x)))
|
||||
#:fce fc*)
|
||||
k))]
|
||||
[#s(ghost:parse _ pattern expr)
|
||||
#`(let ([y (datum->syntax #f (without-fails expr))])
|
||||
(parse:S y #,(frontier:add-subparse (wash #'fc) #'y)
|
||||
pattern k))])]))
|
||||
#`(let* ([y (datum->syntax #f (without-fails expr))]
|
||||
[fc* (dfc-add-post fc y)])
|
||||
(parse:S y fc* pattern k))])]))
|
||||
|
||||
(begin-for-syntax
|
||||
;; convert-list-pattern : ListPattern id -> SinglePattern
|
||||
|
|
@ -348,6 +347,9 @@
|
|||
[#s(pat:name attrs pattern names)
|
||||
(with-syntax ([pattern (convert-list-pattern #'pattern end-pattern)])
|
||||
#'#s(pat:name attrs pattern names))]
|
||||
[#s(pat:ghost attrs ghost tail)
|
||||
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
|
||||
#'#s(pat:ghost attrs ghost tail))]
|
||||
[#s(pat:head attrs head tail)
|
||||
(with-syntax ([tail (convert-list-pattern #'tail end-pattern)])
|
||||
#'#s(pat:head attrs head tail))]
|
||||
|
|
@ -361,7 +363,7 @@
|
|||
;; (parse:H id FCE HeadPattern id id expr) : expr
|
||||
(define-syntax (parse:H stx)
|
||||
(syntax-case stx ()
|
||||
[(parse:H x fc head rest index k)
|
||||
[(parse:H x fc head rest rest-fc k)
|
||||
(syntax-case #'head ()
|
||||
[#s(hpat:describe _ description transparent? pattern)
|
||||
#`(let ([previous-fail enclosing-fail]
|
||||
|
|
@ -370,70 +372,66 @@
|
|||
(fail x
|
||||
#:expect (expectation-of-thing description transparent? failure)
|
||||
#:fce fc))
|
||||
(let ([fc* (dfc-empty x)])
|
||||
(with-enclosing-fail* new-fail
|
||||
(parse:H x #,(empty-frontier #'x) pattern
|
||||
rest index
|
||||
(parse:H x fc* pattern rest rest-fc
|
||||
(with-enclosing-cut-fail previous-cut-fail
|
||||
(with-enclosing-fail previous-fail
|
||||
k)))))]
|
||||
k))))))]
|
||||
[#s(hpat:var _attrs name parser (arg ...) (nested-a ...))
|
||||
#`(let ([result (parser x)])
|
||||
(if (ok? result)
|
||||
(let ([rest (car result)]
|
||||
[index (cadr result)])
|
||||
(let* ([rest (car result)]
|
||||
[local-fc (cadr result)]
|
||||
[rest-fc (dfc-append fc local-fc)])
|
||||
(let-attributes (#,@(if (identifier? #'name)
|
||||
#'([#s(attr name 0 #t)
|
||||
(stx-list-take x index)])
|
||||
(stx-list-take x (dfc->index local-fc))])
|
||||
#'()))
|
||||
(let/unpack ((nested-a ...) (cddr result))
|
||||
k)))
|
||||
(fail x #:expect result #:fce fc)))]
|
||||
[#s(hpat:and (a ...) head single)
|
||||
#`(parse:H x fc head rest index
|
||||
(let ([lst (stx-list-take x index)])
|
||||
#`(parse:H x fc head rest rest-fc
|
||||
(let ([lst (stx-list-take x (dfc-difference fc rest-fc))])
|
||||
(parse:S lst fc single k)))]
|
||||
[#s(hpat:or (a ...) (subpattern ...))
|
||||
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
|
||||
#`(let ([success
|
||||
(lambda (rest index fail id ...)
|
||||
(lambda (rest rest-fc fail id ...)
|
||||
(with-enclosing-fail fail
|
||||
(let-attributes ([a id] ...) k)))])
|
||||
(try (parse:H x fc subpattern rest index
|
||||
(try (parse:H x fc subpattern rest rest-fc
|
||||
(disjunct subpattern success
|
||||
(rest index enclosing-fail) (id ...)))
|
||||
(rest rest-fc enclosing-fail) (id ...)))
|
||||
...)))]
|
||||
[#s(hpat:seq attrs pattern)
|
||||
(with-syntax ([index0 (frontier->index-expr (wash #'fc))])
|
||||
(with-syntax ([pattern
|
||||
(convert-list-pattern
|
||||
#'pattern
|
||||
#'#s(internal-rest-pattern rest index index0))])
|
||||
#'(parse:S x fc pattern k)))]
|
||||
#'#s(internal-rest-pattern rest rest-fc))])
|
||||
#'(parse:S x fc pattern k))]
|
||||
[#s(hpat:optional (a ...) pattern defaults)
|
||||
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)]
|
||||
[index0 (frontier->index-expr (wash #'fc))])
|
||||
(with-syntax ([(#s(attr id _ _) ...) #'(a ...)])
|
||||
#`(let ([success
|
||||
(lambda (rest index fail id ...)
|
||||
(lambda (rest rest-fc fail id ...)
|
||||
(with-enclosing-fail fail
|
||||
(let-attributes ([a id] ...) k)))])
|
||||
(try (parse:H x fc pattern rest index
|
||||
(success rest index enclosing-fail (attribute id) ...))
|
||||
(try (parse:H x fc pattern rest rest-fc
|
||||
(success rest rest-fc enclosing-fail (attribute id) ...))
|
||||
(let ([rest x]
|
||||
[index index0])
|
||||
[rest-fc fc])
|
||||
(convert-sides x defaults
|
||||
(clause-success ()
|
||||
(disjunct/sides defaults success
|
||||
(rest index enclosing-fail)
|
||||
(rest rest-fc enclosing-fail)
|
||||
(id ...))))))))]
|
||||
[_
|
||||
(with-syntax ([attrs (pattern-attrs (wash #'head))]
|
||||
[index0 (frontier->index-expr (wash #'fc))])
|
||||
(with-syntax ([attrs (pattern-attrs (wash #'head))])
|
||||
#'(parse:S x fc
|
||||
#s(pat:compound attrs
|
||||
#:pair
|
||||
(head #s(internal-rest-pattern
|
||||
rest index
|
||||
index0)))
|
||||
(head #s(internal-rest-pattern rest rest-fc)))
|
||||
k))])]))
|
||||
|
||||
;; (parse:dots id FCE EHPattern SinglePattern expr) : expr
|
||||
|
|
@ -462,34 +460,33 @@
|
|||
[(rel-rep ...) rel-rep-ids]
|
||||
[(rel-repc ...) rel-repcs]
|
||||
[(a ...) attrs]
|
||||
[(attr-repc ...) attr-repcs]
|
||||
[loop-fc (frontier:add-index (wash #'fc) #'index)])
|
||||
[(attr-repc ...) attr-repcs])
|
||||
(define-pattern-variable alt-map #'((id . alt-id) ...))
|
||||
(define-pattern-variable loop-k
|
||||
#'(dots-loop dx (+ index index2) enclosing-fail rel-rep ... alt-id ...))
|
||||
#'(dots-loop dx loop-fc* enclosing-fail rel-rep ... alt-id ...))
|
||||
#`(let ()
|
||||
(define (dots-loop dx index loop-fail rel-rep ... alt-id ...)
|
||||
(define (dots-loop dx loop-fc loop-fail rel-rep ... alt-id ...)
|
||||
(with-enclosing-fail loop-fail
|
||||
(try (parse:EH dx loop-fc head head-repc index2 alt-map head-rep
|
||||
(try (parse:EH dx loop-fc head head-repc loop-fc* alt-map head-rep
|
||||
loop-k)
|
||||
...
|
||||
(cond [(< rel-rep (rep:min-number rel-repc))
|
||||
(fail dx
|
||||
#:expect (expectation-of-reps/too-few rel-rep rel-repc)
|
||||
#:fce loop-fc)]
|
||||
#:fce (dfc-add-pre loop-fc #f))]
|
||||
...
|
||||
[else
|
||||
(let-attributes ([a (rep:finalize a attr-repc alt-id)] ...)
|
||||
(parse:S dx loop-fc tail k))]))))
|
||||
(let ([rel-rep 0] ...
|
||||
[alt-id (rep:initial-value attr-repc)] ...)
|
||||
(dots-loop x 0 enclosing-fail rel-rep ... alt-id ...)))))]))
|
||||
(dots-loop x fc enclosing-fail rel-rep ... alt-id ...)))))]))
|
||||
|
||||
;; (parse:EH id FCE EHPattern id id ((id . id) ...)
|
||||
;; RepConstraint/#f expr) : expr
|
||||
(define-syntax (parse:EH stx)
|
||||
(syntax-case stx ()
|
||||
[(parse:EH x fc head repc index alts rep k0)
|
||||
[(parse:EH x fc head repc fc* alts rep k0)
|
||||
(let ()
|
||||
(define-pattern-variable k
|
||||
(let* ([main-attrs (wash-iattrs (pattern-attrs (wash #'head)))]
|
||||
|
|
@ -506,14 +503,13 @@
|
|||
#`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...)
|
||||
k0))))
|
||||
(syntax-case #'repc ()
|
||||
[#f #`(parse:H x fc head x index k)]
|
||||
[_ #`(parse:H x fc head x index
|
||||
[#f #`(parse:H x fc head x fc* k)]
|
||||
[_ #`(parse:H x fc head x fc*
|
||||
(if (< rep (rep:max-number repc))
|
||||
(let ([rep (add1 rep)]) k)
|
||||
(fail x
|
||||
#:expect (expectation-of-reps/too-many rep repc)
|
||||
#:fce #,(frontier:add-index (wash #'fc)
|
||||
#'index))))]))]))
|
||||
#:fce fc*)))]))]))
|
||||
|
||||
;; (rep:initial-value RepConstraint) : expr
|
||||
(define-syntax (rep:initial-value stx)
|
||||
|
|
|
|||
|
|
@ -11,23 +11,27 @@
|
|||
(for-syntax "../util/error.ss")
|
||||
"runtime.ss")
|
||||
(provide syntax-patterns-fail
|
||||
current-failure-handler)
|
||||
current-failure-handler
|
||||
simplify-failure)
|
||||
|
||||
;; Failure reporting parameter & default
|
||||
|
||||
(define (default-failure-handler stx0 f)
|
||||
(match (simplify-failure f)
|
||||
[#s(failure x frontier frontier-stx expectation)
|
||||
(report-failure stx0 x (last frontier) frontier-stx expectation)]))
|
||||
[#s(failure x frontier expectation)
|
||||
(report-failure stx0 x (dfc->index frontier) (dfc->stx frontier) expectation)]))
|
||||
|
||||
(define current-failure-handler
|
||||
(make-parameter default-failure-handler))
|
||||
|
||||
(define ((syntax-patterns-fail stx0) f)
|
||||
(let ([value ((current-failure-handler) stx0 f)])
|
||||
(call-with-values (lambda () ((current-failure-handler) stx0 f))
|
||||
(lambda vals
|
||||
(error 'current-failure-handler
|
||||
"current-failure-handler: did not escape, produced ~e" value)))
|
||||
|
||||
"current-failure-handler: did not escape, produced ~e"
|
||||
(case (length vals)
|
||||
((1) (car vals))
|
||||
(else (cons 'values vals)))))))
|
||||
|
||||
;; report-failure : stx stx number stx Expectation -> (escapes)
|
||||
(define (report-failure stx0 x index frontier-stx expected)
|
||||
|
|
@ -39,6 +43,7 @@
|
|||
[(one)
|
||||
(err "unexpected term" stx0 #'one)]
|
||||
[(first . more)
|
||||
;; TODO: report error with all elements (use improper-stx->list)
|
||||
(err "unexpected terms starting here" stx0 #'first)]
|
||||
[_
|
||||
(err "unexpected term" stx0 x)])]
|
||||
|
|
@ -48,7 +53,6 @@
|
|||
(err (format "~a~a"
|
||||
msg
|
||||
(cond [(zero? index) ""]
|
||||
[(= index +inf.0) "" #|" after matching main pattern"|#]
|
||||
[else (format " after ~s ~a"
|
||||
index
|
||||
(if (= 1 index) "term" "terms"))]))
|
||||
|
|
@ -57,50 +61,66 @@
|
|||
[else
|
||||
(err "bad syntax" stx0 stx0)]))
|
||||
|
||||
;; FIXME: try different selection/simplification algorithms/heuristics
|
||||
;; simplify-failure : Failure -> SimpleFailure
|
||||
(define (simplify-failure f)
|
||||
(simplify* f))
|
||||
|
||||
;; simplify* : Failure -> SimpleFailure
|
||||
(define (simplify* f)
|
||||
(match f
|
||||
[#s(join-failures f1 f2)
|
||||
(choose-error (simplify-failure f1) (simplify-failure f2))]
|
||||
[#s(failure x frontier frontier-stx expectation)
|
||||
(choose-error (simplify* f1) (simplify* f2))]
|
||||
[#s(failure x frontier expectation)
|
||||
(match expectation
|
||||
[#s(expect:thing description '#t chained)
|
||||
(let ([new-f (simplify-failure (adjust-failure chained frontier frontier-stx))])
|
||||
(match new-f
|
||||
[#s(failure _ _ _ new-e)
|
||||
(if (ineffable? new-e)
|
||||
;; If unfolded failure is ineffable, fall back to the one with description
|
||||
f
|
||||
new-f)]
|
||||
[_ new-f]))]
|
||||
(let ([chained* (simplify* chained)])
|
||||
(match chained*
|
||||
[#s(failure _ chained*-frontier chained*-expectation)
|
||||
(cond [(ineffable? chained*-expectation)
|
||||
;; If simplified chained failure is ineffable,
|
||||
;; keep (& adjust) its frontier
|
||||
;; and attach enclosing description
|
||||
(adjust-failure
|
||||
(make-failure x chained*-frontier
|
||||
(make-expect:thing description #f #f))
|
||||
frontier)]
|
||||
[else
|
||||
;; Otherwise, "expose" the chained failure and
|
||||
;; adjust its frontier
|
||||
(adjust-failure chained* frontier)])]))]
|
||||
[_ f])]))
|
||||
|
||||
(define (adjust-failure f base-frontier base-frontier-stx)
|
||||
;; FIXME: try different selection/simplification algorithms/heuristics
|
||||
(define (simplify-failure0 f)
|
||||
(match f
|
||||
[#s(join-failures f1 f2)
|
||||
(make-join-failures
|
||||
(adjust-failure f1 base-frontier base-frontier-stx)
|
||||
(adjust-failure f2 base-frontier base-frontier-stx))]
|
||||
[#s(failure x frontier frontier-stx expectation)
|
||||
(let-values ([(frontier frontier-stx)
|
||||
(combine-frontiers base-frontier base-frontier-stx
|
||||
frontier frontier-stx)])
|
||||
(make-failure x frontier frontier-stx expectation))]))
|
||||
|
||||
(define (combine-frontiers dfc0 stx0 dfc stx)
|
||||
(cond [(null? (cdr dfc0))
|
||||
(values (cons (+ (car dfc0) (car dfc))
|
||||
(cdr dfc))
|
||||
(if (null? (cdr dfc))
|
||||
stx0
|
||||
stx))]
|
||||
(choose-error (simplify-failure0 f1) (simplify-failure0 f2))]
|
||||
[#s(failure x frontier expectation)
|
||||
(match expectation
|
||||
[#s(expect:thing description '#t chained)
|
||||
(let ([chained* (simplify-failure0 chained)])
|
||||
(match chained*
|
||||
[#s(failure _ _ chained*-expectation)
|
||||
(cond [(ineffable? chained*-expectation)
|
||||
;; If simplified chained failure is ineffable, ignore it
|
||||
;; and stick to the one with the description
|
||||
f]
|
||||
[else
|
||||
(let-values ([(f s) (combine-frontiers (cdr dfc0) stx0 dfc stx)])
|
||||
(values (cons (car dfc0) f) s))]))
|
||||
;; Otherwise, "expose" the chained failure
|
||||
;; and adjust its frontier
|
||||
(adjust-failure chained* frontier)])]))]
|
||||
[_ f])]))
|
||||
|
||||
;; choose-error : Failure Failure -> Result
|
||||
(define (adjust-failure f base-frontier)
|
||||
(match f
|
||||
[#s(failure x frontier expectation)
|
||||
(let ([frontier (dfc-append base-frontier frontier)])
|
||||
(make-failure x frontier expectation))]))
|
||||
|
||||
;; choose-error : Failure Failure -> Failure
|
||||
(define (choose-error f1 f2)
|
||||
(case (compare-dfcs (failure-frontier f1) (failure-frontier f2))
|
||||
(case (compare-idfcs (invert-dfc (failure-frontier f1))
|
||||
(invert-dfc (failure-frontier f2)))
|
||||
[(>) f1]
|
||||
[(<) f2]
|
||||
[(=) (merge-failures f1 f2)]))
|
||||
|
|
@ -109,7 +129,6 @@
|
|||
(define (merge-failures f1 f2)
|
||||
(make-failure (failure-stx f1)
|
||||
(failure-frontier f1)
|
||||
(failure-frontier-stx f1)
|
||||
(merge-expectations (failure-expectation f1)
|
||||
(failure-expectation f2))))
|
||||
|
||||
|
|
@ -163,3 +182,9 @@
|
|||
[(2) (format "~a~a ~a~a" prefix (car items) ult (cadr items))]
|
||||
[else (let ([strings (list* (car items) (loop (cdr items)))])
|
||||
(apply string-append prefix strings))]))
|
||||
|
||||
(define (improper-stx->list stx)
|
||||
(syntax-case stx ()
|
||||
[(a . b) (cons #'a (improper-stx->list #'b))]
|
||||
[() null]
|
||||
[rest (list #'rest)]))
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(require scheme/contract/base
|
||||
scheme/stxparam
|
||||
scheme/list
|
||||
"minimatch.ss"
|
||||
(for-syntax scheme/base
|
||||
syntax/stx
|
||||
scheme/private/sc
|
||||
|
|
@ -32,8 +33,6 @@
|
|||
|
||||
this-syntax
|
||||
|
||||
compare-dfcs
|
||||
|
||||
expect?
|
||||
expectation?
|
||||
(struct-out expect:thing)
|
||||
|
|
@ -121,21 +120,161 @@
|
|||
|
||||
;; == Dynamic Frontier Contexts (DFCs)
|
||||
|
||||
;; A DFC is a list of numbers.
|
||||
(provide (struct-out dfc:empty)
|
||||
(struct-out dfc:car)
|
||||
(struct-out dfc:cdr)
|
||||
(struct-out dfc:pre)
|
||||
(struct-out dfc:post)
|
||||
dfc-empty
|
||||
dfc-add-car
|
||||
dfc-add-cdr
|
||||
dfc-add-pre
|
||||
dfc-add-post
|
||||
dfc-add-unbox
|
||||
dfc-add-unvector
|
||||
dfc-add-unpstruct
|
||||
|
||||
;; compare-dfcs : DFC DFC -> (one-of '< '= '>)
|
||||
dfc->index
|
||||
dfc->stx
|
||||
dfc-difference
|
||||
dfc-append
|
||||
|
||||
invert-dfc
|
||||
compare-idfcs
|
||||
idfc>?
|
||||
idfc=?)
|
||||
|
||||
#|
|
||||
A Dynamic Frontier Context (DFC) is one of
|
||||
- (make-dfc:empty stx)
|
||||
- (make-dfc:car DFC stx)
|
||||
- (make-dfc:cdr DFC positive-integer)
|
||||
- (make-dfc:pre DFC stx)
|
||||
- (make-dfc:post DFC stx)
|
||||
|#
|
||||
|
||||
(define-struct dfc:empty (stx) #:prefab)
|
||||
(define-struct dfc:car (parent stx) #:prefab)
|
||||
(define-struct dfc:cdr (parent n) #:prefab)
|
||||
(define-struct dfc:pre (parent stx) #:prefab)
|
||||
(define-struct dfc:post (parent stx) #:prefab)
|
||||
|
||||
(define (dfc-empty x) (make-dfc:empty x))
|
||||
(define (dfc-add-car parent stx)
|
||||
(make-dfc:car parent stx))
|
||||
(define (dfc-add-cdr parent _)
|
||||
(match parent
|
||||
[#s(dfc:cdr uberparent n)
|
||||
(make-dfc:cdr uberparent (add1 n))]
|
||||
[_ (make-dfc:cdr parent 1)]))
|
||||
(define (dfc-add-pre parent stx)
|
||||
(make-dfc:pre parent stx))
|
||||
(define (dfc-add-post parent stx)
|
||||
(make-dfc:post parent stx))
|
||||
|
||||
(define (dfc-add-unbox parent stx)
|
||||
(dfc-add-car parent stx))
|
||||
(define (dfc-add-unvector parent stx)
|
||||
(dfc-add-car parent stx))
|
||||
(define (dfc-add-unpstruct parent stx)
|
||||
(dfc-add-car parent stx))
|
||||
|
||||
(define (dfc->index dfc)
|
||||
(match dfc
|
||||
[#s(dfc:cdr parent n) n]
|
||||
[_ 0]))
|
||||
|
||||
(define (dfc->stx dfc)
|
||||
(match dfc
|
||||
[#s(dfc:empty stx) stx]
|
||||
[#s(dfc:car parent stx) stx]
|
||||
[#s(dfc:cdr parent n) (dfc->stx parent)]
|
||||
[#s(dfc:pre parent stx) stx]
|
||||
[#s(dfc:post parent stx) stx]))
|
||||
|
||||
;; dfc-difference : DFC DFC -> nat
|
||||
;; Returns N s.t. B = (dfc-add-cdr^N A)
|
||||
(define (dfc-difference a b)
|
||||
(define (whoops)
|
||||
(error 'dfc-difference "~e is not an extension of ~e"
|
||||
(frontier->sexpr b) (frontier->sexpr a)))
|
||||
(match (list a b)
|
||||
[(list #s(dfc:cdr pa na) #s(dfc:cdr pb nb))
|
||||
(unless (equal? pa pb) (whoops))
|
||||
(- nb na)]
|
||||
[(list pa #s(dfc:cdr pb nb))
|
||||
(unless (equal? pa pb) (whoops))
|
||||
nb]
|
||||
[_
|
||||
(unless (equal? a b) (whoops))
|
||||
0]))
|
||||
|
||||
;; dfc-append : DFC DFC -> DFC
|
||||
;; puts A at the base, B on top
|
||||
(define (dfc-append a b)
|
||||
(match b
|
||||
[#s(dfc:empty stx) a]
|
||||
[#s(dfc:car pb stx) (make-dfc:car (dfc-append a pb) stx)]
|
||||
[#s(dfc:cdr #s(dfc:empty _) nb)
|
||||
;; Special case to merge "consecutive" cdr frames
|
||||
(match a
|
||||
[#s(dfc:cdr pa na) (make-dfc:cdr pa (+ na nb))]
|
||||
[_ (make-dfc:cdr a nb)])]
|
||||
[#s(dfc:cdr pb nb) (make-dfc:cdr (dfc-append a pb) nb)]
|
||||
[#s(dfc:pre pb stx) (make-dfc:pre (dfc-append a pb) stx)]
|
||||
[#s(dfc:post pb stx) (make-dfc:post (dfc-append a pb) stx)]))
|
||||
|
||||
|
||||
;; An Inverted DFC (IDFC) is a DFC inverted for easy comparison.
|
||||
|
||||
(define (invert-dfc dfc)
|
||||
(define (invert dfc acc)
|
||||
(match dfc
|
||||
[#s(dfc:empty _) acc]
|
||||
[#s(dfc:car parent stx)
|
||||
(invert parent (make-dfc:car acc stx))]
|
||||
[#s(dfc:cdr parent n)
|
||||
(invert parent (make-dfc:cdr acc n))]
|
||||
[#s(dfc:pre parent stx)
|
||||
(invert parent (make-dfc:pre acc stx))]
|
||||
[#s(dfc:post parent stx)
|
||||
(invert parent (make-dfc:post acc stx))]))
|
||||
(invert dfc (dfc-empty 'dummy)))
|
||||
|
||||
;; compare-idfcs : IDFC IDFC -> (one-of '< '= '>)
|
||||
;; Note A>B means A is "further along" than B.
|
||||
(define (compare-dfcs a b)
|
||||
(cond [(and (null? a) (null? b))
|
||||
'=]
|
||||
[(and (pair? a) (null? b))
|
||||
'>]
|
||||
[(and (null? a) (pair? b))
|
||||
'<]
|
||||
[(and (pair? a) (pair? b))
|
||||
(cond [(> (car a) (car b)) '>]
|
||||
[(< (car a) (car b)) '<]
|
||||
[else (compare-dfcs (cdr a) (cdr b))])]))
|
||||
;; Lexicographic generalization of PRE < CAR < CDR < POST
|
||||
(define (compare-idfcs a b)
|
||||
(match (list a b)
|
||||
;; Same constructors
|
||||
[(list #s(dfc:empty _) #s(dfc:empty _)) '=]
|
||||
[(list #s(dfc:car pa _) #s(dfc:car pb _))
|
||||
(compare-idfcs pa pb)]
|
||||
[(list #s(dfc:cdr pa na) #s(dfc:cdr pb nb))
|
||||
(cond [(< na nb) '<]
|
||||
[(> na nb) '>]
|
||||
[(= na nb) (compare-idfcs pa pb)])]
|
||||
[(list #s(dfc:pre pa _) #s(dfc:pre pb _))
|
||||
;; FIXME: possibly just '= here, treat all sides as equiv
|
||||
(compare-idfcs pa pb)]
|
||||
[(list #s(dfc:post pa _) #s(dfc:post pb _))
|
||||
;; FIXME: possibly just '= here, treat all sides as equiv
|
||||
(compare-idfcs pa pb)]
|
||||
;; Different constructors
|
||||
[(list #s(dfc:empty _) _) '<]
|
||||
[(list _ #s(dfc:empty _)) '>]
|
||||
[(list #s(dfc:pre _ _) _) '<]
|
||||
[(list _ #s(dfc:pre _ _)) '>]
|
||||
[(list #s(dfc:car _ _) _) '<]
|
||||
[(list _ #s(dfc:car _ _)) '>]
|
||||
[(list #s(dfc:cdr _ _) _) '<]
|
||||
[(list _ #s(dfc:cdr _ _)) '>]))
|
||||
|
||||
(define (idfc>? a b)
|
||||
(eq? (compare-idfcs a b) '>))
|
||||
|
||||
(define (idfc=? a b)
|
||||
(eq? (compare-idfcs a b) '=))
|
||||
|
||||
;; == Codegen internal syntax parameters
|
||||
|
||||
|
|
@ -174,12 +313,12 @@
|
|||
;; == Success and Failure
|
||||
|
||||
;; A Failure is one of
|
||||
;; (make-failure stx DFC stx expectation/c)
|
||||
;; (make-failure stx DFC expectation/c)
|
||||
;; (make-join-failures Failure Failure)
|
||||
|
||||
(define ok? list?)
|
||||
|
||||
(define-struct failure (stx frontier frontier-stx expectation) #:prefab)
|
||||
(define-struct failure (stx frontier expectation) #:prefab)
|
||||
(define-struct join-failures (f1 f2) #:prefab)
|
||||
|
||||
;; (try expr ...)
|
||||
|
|
@ -387,3 +526,44 @@ An Expectation is one of
|
|||
(for ([x v]) (loop (sub1 n) x))))
|
||||
(loop n0 v0)
|
||||
v0)
|
||||
|
||||
|
||||
;; ----
|
||||
|
||||
;; debugging
|
||||
|
||||
(provide failure->sexpr
|
||||
one-failure->sexpr
|
||||
frontier->sexpr
|
||||
expectation->sexpr)
|
||||
|
||||
(define (failure->sexpr f)
|
||||
(define fs
|
||||
(let loop ([f f])
|
||||
(match f
|
||||
[#s(join-failures f1 f2)
|
||||
(append (loop f1) (loop f2))]
|
||||
[_ (list f)])))
|
||||
(case (length fs)
|
||||
((1) (one-failure->sexpr f))
|
||||
(else `(union ,@(map one-failure->sexpr fs)))))
|
||||
|
||||
(define (one-failure->sexpr f)
|
||||
(match f
|
||||
[#s(failure x frontier expectation)
|
||||
`(failure ,(frontier->sexpr frontier)
|
||||
#:term ,(syntax->datum x)
|
||||
#:expected ,(expectation->sexpr expectation))]))
|
||||
|
||||
(define (frontier->sexpr dfc)
|
||||
(match (invert-dfc dfc)
|
||||
[#s(dfc:empty _) '()]
|
||||
[#s(dfc:car p _) (cons 0 (frontier->sexpr p))]
|
||||
[#s(dfc:cdr p n) (cons n (frontier->sexpr p))]
|
||||
[#s(dfc:side p _) (cons 'side (frontier->sexpr p))]))
|
||||
|
||||
(define (expectation->sexpr expectation)
|
||||
(match expectation
|
||||
[#s(expect:thing thing '#t chained)
|
||||
(make-expect:thing thing #t (failure->sexpr chained))]
|
||||
[_ expectation]))
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@
|
|||
|
||||
debug-rhs
|
||||
debug-pattern
|
||||
debug-parse
|
||||
|
||||
syntax-parse
|
||||
syntax-parser
|
||||
|
|
@ -175,6 +176,14 @@
|
|||
(let ([p (parse-whole-pattern #'p (new-declenv null) #:context stx)])
|
||||
#`(quote #,p))]))
|
||||
|
||||
(define-syntax-rule (debug-parse x p)
|
||||
(let/ec escape
|
||||
(parameterize ((current-failure-handler
|
||||
(lambda (_ f)
|
||||
(escape (failure->sexpr f)
|
||||
(failure->sexpr (simplify-failure f))))))
|
||||
(syntax-parse x [p 'success]))))
|
||||
|
||||
(define-syntax (syntax-parse stx)
|
||||
(syntax-case stx ()
|
||||
[(syntax-parse stx-expr . clauses)
|
||||
|
|
|
|||
88
collects/tests/stxparse/select.ss
Normal file
88
collects/tests/stxparse/select.ss
Normal file
|
|
@ -0,0 +1,88 @@
|
|||
#lang scheme
|
||||
(require schemeunit
|
||||
syntax/parse)
|
||||
(require (for-syntax syntax/parse))
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; Error selection tests
|
||||
|
||||
(error-print-source-location #f)
|
||||
|
||||
(define-syntax-rule (terx s p stuff ...)
|
||||
(terx* s [p] stuff ...))
|
||||
|
||||
(define-syntax terx*
|
||||
(syntax-parser
|
||||
[(terx s [p ...] (~optional (~seq #:term term) #:defaults ([term #'#f])) rx ...)
|
||||
#'(test-case (format "line ~s: ~a match ~s for error"
|
||||
(syntax-line (quote-syntax s))
|
||||
's '(p ...))
|
||||
(let ([exn (let/ec escape
|
||||
(check-exn (lambda (exn)
|
||||
(escape exn))
|
||||
(lambda ()
|
||||
(syntax-parse (quote-syntax s)
|
||||
[p 'ok] ...))))])
|
||||
(let ([msg (exn-message exn)]
|
||||
[stxs (and (exn:fail:syntax? exn)
|
||||
(exn:fail:syntax-exprs exn))])
|
||||
(when 'term
|
||||
(check-equal? (and (pair? stxs) (syntax->datum (car stxs))) 'term))
|
||||
(erx rx (exn-message exn)) ... #t))
|
||||
'ok)]))
|
||||
|
||||
(define-syntax erx
|
||||
(syntax-rules (not)
|
||||
[(erx (not rx) msg)
|
||||
(check (compose not regexp-match?) rx msg)]
|
||||
[(erx rx msg)
|
||||
(check regexp-match? rx msg)]))
|
||||
|
||||
;; ----
|
||||
|
||||
(terx* (1 2) [x:nat (y:id z:id)]
|
||||
#:term 1
|
||||
#rx"expected identifier")
|
||||
|
||||
;; --
|
||||
|
||||
(define-syntax-class bindings
|
||||
(pattern ((var:id rhs:expr) ...)))
|
||||
|
||||
(terx* ((x 1 2)) [x:id bs:bindings]
|
||||
#:term 2
|
||||
#rx"unexpected term")
|
||||
|
||||
;; --
|
||||
|
||||
(terx ((a 1) (a 2))
|
||||
((~or (~once ((~datum a) x) #:name "A clause")
|
||||
(~optional ((~datum b) y) #:name "B clause"))
|
||||
...)
|
||||
;; #:term (a 2)
|
||||
#rx"too many occurrences of A clause")
|
||||
|
||||
;; --
|
||||
|
||||
(define-syntax-class A
|
||||
(pattern ((~datum a) x)))
|
||||
(define-syntax-class B
|
||||
(pattern ((~datum b) y)))
|
||||
|
||||
(terx ((a 1) (a 2))
|
||||
((~or (~once a:A #:name "A clause")
|
||||
(~optional b:B #:name "B clause"))
|
||||
...)
|
||||
#rx"too many occurrences of A clause")
|
||||
|
||||
(terx ((a 1 2) _)
|
||||
((~or (~once a:A #:name "A clause")
|
||||
(~optional b:B #:name "B clause"))
|
||||
...)
|
||||
#rx"unexpected term")
|
||||
|
||||
(terx ((b 1 2) _)
|
||||
((~or (~once a:A #:name "A clause")
|
||||
(~optional b:B #:name "B clause"))
|
||||
...)
|
||||
#rx"unexpected term")
|
||||
|
|
@ -1,7 +1,6 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (planet schematics/schemeunit:2:9/test)
|
||||
(planet schematics/schemeunit:2:9/graphical-ui)
|
||||
(require schemeunit
|
||||
syntax/parse
|
||||
(for-syntax scheme/base syntax/parse))
|
||||
|
||||
|
|
@ -95,15 +94,15 @@
|
|||
|
||||
;; Tests
|
||||
|
||||
(define tests
|
||||
(test-suite "Syntax grammars"
|
||||
(test-suite "sc attrs"
|
||||
(begin ;; define tests
|
||||
(begin ;; test-suite "Syntax grammars"
|
||||
(begin ;; test-suite "sc attrs"
|
||||
(test-sc-attrs one ([a 0]))
|
||||
(test-sc-attrs two ([a 0] [b 0]))
|
||||
(test-sc-attrs three ([a 0] [b 0] [c 0]))
|
||||
(test-sc-attrs two-or-three/tag ([a 0] [a.a 0] [a.b 0]))
|
||||
(test-sc-attrs id-num ([x 0] [n 0])))
|
||||
(test-suite "parse-sc"
|
||||
(begin ;; test-suite "parse-sc"
|
||||
(test-parse-sc one #'1 ([a 0 1]))
|
||||
(test-parse-sc two #'(1 2) ([a 0 1] [b 0 2]))
|
||||
(test-parse-sc three #'(1 2 3) ([a 0 1] [b 0 2] [c 0 3]))
|
||||
|
|
@ -113,7 +112,7 @@
|
|||
([x 0 this] [n 0 12]))
|
||||
(test-parse-sc id-string #'(that "here")
|
||||
([x 0 that] [label 0 "here"])))
|
||||
(test-suite "with-patterns"
|
||||
(begin ;; test-suite "with-patterns"
|
||||
(test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8))
|
||||
(check-equal? (syntax->datum #'(t.a ...)) '(1 4 6)))
|
||||
(test-patterns (t:two-to-four/untagged ...) #'((1 2 3) (4 5) (6 7 8))
|
||||
|
|
|
|||
|
|
@ -54,7 +54,7 @@
|
|||
(syntax-line (quote-syntax s))
|
||||
's '(p ...))
|
||||
(check-exn (lambda (exn)
|
||||
(erx rx (exn-message exn)) ...)
|
||||
(erx rx (exn-message exn)) ... #t)
|
||||
(lambda ()
|
||||
(syntax-parse (quote-syntax s)
|
||||
[p 'ok] ...)))
|
||||
|
|
@ -63,7 +63,7 @@
|
|||
(define-syntax erx
|
||||
(syntax-rules (not)
|
||||
[(erx (not rx) msg)
|
||||
(check-false (regexp-match? rx msg))]
|
||||
(check (compose not regexp-match?) rx msg)]
|
||||
[(erx rx msg)
|
||||
(check regexp-match? rx msg)]))
|
||||
|
||||
|
|
@ -220,8 +220,8 @@
|
|||
;; -- A patterns
|
||||
|
||||
;; cut patterns
|
||||
(terx* (1 2 3) [(1 ~! 4) (1 2 3)]
|
||||
"4" (not "2"))
|
||||
(terx* (1 2 3) [(1 ~! 4) (1 _:nat 3)]
|
||||
"4" (not "exact nonnegative integer"))
|
||||
|
||||
;; cut-in-and
|
||||
(terx* 1 [(~and a:nat ~! 2) b:nat]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user