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

[private] rx: add annotation, to avoid prevent contract errors

Browse Source
This commit is contained in:
Ben Greenman 2016-06-13 20:42:20 -04:00
parent f99ef2ffa1
commit d2a4b87d4d
2 changed files with 19 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
test/regexp-fail.rkt
View File

@ -48,8 +48,16 @@
;; -- expected String, given Bytes
(with-input-from-string "hello"
(lambda ()
(define m (regexp-match #rx#"lang" (current-input-port)))
(define m (regexp-match: #rx#"lang" (current-input-port)))
(and m (string=? (car m) "lang"))))
;; ---- is raising a type error, which is GOOD, but throwing during test
;;; -- return type assumed to be String, but really is Bytes
;;; (ugly, but at least we catch it statically)
;(with-input-from-file "test/regexp-fail.rkt"
; (lambda ()
; (define m (regexp-match: #rx"lang" (current-input-port)))
; (and m (bytes=? #;string=? (car m) #"lang"))))
)
;; 2016-06-13 : these really should be errors, just no-opts

18
trivial/private/regexp.rkt
View File

@ -239,9 +239,9 @@
(or (eq? pattern-sym 'String)
(eq? pattern-sym 'Regexp))
(or (syntax-parse arg-stx
((x:str) #t)
((x) #:when (bytes? (syntax-e #'x)) #f)
;; TODO ;; ((x) #:when (port? (syntax-e #'x)) #f)
((x:str arg* ...) #t)
((x arg* ...) #:when (bytes? (syntax-e #'x)) #f)
;; TODO ;; ((x arg* ...) #:when (port? (syntax-e #'x)) #f)
(_ #t))))
'String
'Bytes))
@ -276,16 +276,18 @@
(syntax/loc stx pat.evidence)
#:with return-type
(format-id stx "~a" (infer-return-type (syntax-e #'type-sym) #'(arg* ...)))
#:with (group-type* ...)
#:with (exact-group-type* ...)
(let ([stx-never-fail (syntax/loc stx return-type)]
[stx-may-fail (syntax/loc stx (U #f return-type))])
(for/list ([c-stx (in-list (syntax-e #'capture?*))])
(if (syntax-e c-stx)
stx-never-fail
stx-may-fail)))
(if (syntax-e c-stx) stx-never-fail stx-may-fail)))
(syntax/loc stx
(let ([maybe-match (regexp-match pat.expanded arg* ...)])
(if maybe-match
(cast maybe-match (List return-type group-type* ...))
(cast ;; -- use `ann` to validate return type assumption & `cast` to remove #f
;; 2016-06-13: ideally we should be typechecking `arg` instead of guessing
(ann maybe-match (Pairof return-type (Listof (U #f return-type))))
(List return-type exact-group-type* ...))
#f)))]
[_ #f]))))