add a few more contracts to those that opt/c recognizes and
fix a few bugs in existing ones also, adjust opt/c so that it logs failures to optimize on its own logger
This commit is contained in:
Robby Findler
parent
880b841073
commit
58869e41af
|
|
@ -29,6 +29,7 @@
|
|||
;;
|
||||
(define/opter (false/c opt/i opt/info stx) (opt/pred opt/info #'not #:name '#f))
|
||||
(define/opter (not opt/i opt/info stx) (opt/pred opt/info #'not))
|
||||
(define/opter (contract? opt/i opt/info stx) (opt/pred opt/info #'contract?))
|
||||
|
||||
;;
|
||||
;; flat-contract helper
|
||||
|
|
|
|||
|
|
@ -4,6 +4,9 @@
|
|||
"guts.rkt"
|
||||
"prop.rkt"
|
||||
"misc.rkt"
|
||||
"opt.rkt"
|
||||
"blame.rkt"
|
||||
(for-syntax "opt-guts.rkt")
|
||||
racket/private/class-internal
|
||||
racket/stxparam)
|
||||
|
||||
|
|
@ -116,11 +119,7 @@
|
|||
%/<%>)]))
|
||||
|
||||
(define (is-a?/c <%>)
|
||||
(unless (or (interface? <%>) (class? <%>))
|
||||
(raise-argument-error
|
||||
'is-a?/c
|
||||
(format "~s" '(or/c interface? class?))
|
||||
<%>))
|
||||
(check-is-a?/c <%>)
|
||||
(define name (object-name <%>))
|
||||
(flat-named-contract
|
||||
(cond
|
||||
|
|
@ -132,3 +131,43 @@
|
|||
(lambda (x) (is-a? x <%>))))
|
||||
|
||||
(define mixin-contract (->i ([c% class?]) [res (c%) (subclass?/c c%)]))
|
||||
|
||||
|
||||
(define/opter (is-a?/c opt/i opt/info stx)
|
||||
(syntax-case stx ()
|
||||
[(_ cls)
|
||||
(let ()
|
||||
(define-values (lift-cls lifts1) (lift/binding #'cls 'is-a?/c-cls empty-lifts))
|
||||
(with-syntax ([cls-x lift-cls])
|
||||
(define lifts2 (lift/effect #'(check-is-a?/c cls-x) lifts1))
|
||||
(with-syntax ([val (opt/info-val opt/info)]
|
||||
[ctc (opt/info-contract opt/info)]
|
||||
[blame (opt/info-blame opt/info)]
|
||||
[this (opt/info-this opt/info)]
|
||||
[that (opt/info-that opt/info)])
|
||||
(build-optres
|
||||
#:exp #'(if (is-a? val cls-x)
|
||||
val
|
||||
(raise-is-a?/c-error val cls-x blame))
|
||||
#:lifts lifts2
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat #'(is-a? cls-x val)
|
||||
#:opt #f
|
||||
#:stronger-ribs '()
|
||||
#:chaperone #t
|
||||
#:name #'`(is-a?/c ,(object-name cls-x))))))]
|
||||
[_ (opt/unknown opt/i opt/info stx)]))
|
||||
|
||||
(define (raise-is-a?/c-error val cls-x blame)
|
||||
(raise-blame-error blame val
|
||||
'(expected: "a class matching ~e" given: "~e")
|
||||
cls-x val))
|
||||
|
||||
(define (check-is-a?/c <%>)
|
||||
(unless (or (interface? <%>) (class? <%>))
|
||||
(raise-argument-error
|
||||
'is-a?/c
|
||||
(format "~s" '(or/c interface? class?))
|
||||
<%>)))
|
||||
|
||||
|
|
@ -277,14 +277,20 @@
|
|||
#:chaperone #'(chaperone-contract? lift-var)
|
||||
#:name #'(contract-name lift-var))))
|
||||
|
||||
(define unknown-contract-logger (make-logger 'racket/contract (current-logger)))
|
||||
(define (log-unknown-contract-warning exp [extra-warning ""])
|
||||
(log-warning (string-append (format "warning in ~a:~a: opt/c doesn't know the contract ~s"
|
||||
(syntax-source exp)
|
||||
(if (syntax-line exp)
|
||||
(format "~a:~a" (syntax-line exp) (syntax-column exp))
|
||||
(format ":~a" (syntax-position exp)))
|
||||
(syntax->datum exp))
|
||||
extra-warning)))
|
||||
(when (log-level? unknown-contract-logger 'warning)
|
||||
(define datum (syntax->datum exp))
|
||||
(log-message unknown-contract-logger
|
||||
'warning
|
||||
(string-append (format "warning in ~a:~a: opt/c doesn't know the contract ~s"
|
||||
(syntax-source exp)
|
||||
(if (syntax-line exp)
|
||||
(format "~a:~a" (syntax-line exp) (syntax-column exp))
|
||||
(format ":~a" (syntax-position exp)))
|
||||
datum)
|
||||
extra-warning)
|
||||
datum)))
|
||||
|
||||
|
||||
(define opt-error-name (make-parameter 'opt/c))
|
||||
|
|
|
|||
|
|
@ -12,23 +12,28 @@
|
|||
(provide opt/c define-opt/c define/opter
|
||||
opt/direct
|
||||
begin-lifted
|
||||
raise-opt/pred-error
|
||||
(for-syntax
|
||||
opt/pred
|
||||
define-opt/recursive-fn?
|
||||
define-opt/recursive-fn-neg-blame?-id))
|
||||
|
||||
(define-syntax (define/opter stx)
|
||||
(syntax-case stx ()
|
||||
(define-syntax (define/opter orig-stx)
|
||||
(syntax-case orig-stx ()
|
||||
[(_ (for opt/i opt/info stx) expr ...)
|
||||
(if (identifier? #'for)
|
||||
#'(begin
|
||||
(begin-for-syntax
|
||||
(reg-opter!
|
||||
#'for
|
||||
(λ (opt/i opt/info stx)
|
||||
expr ...)))
|
||||
(void))
|
||||
(error 'define/opter "expected opter name to be an identifier, got ~.s" (syntax-e #'for)))]))
|
||||
(with-syntax ([for/name (datum->syntax #'for
|
||||
(string->symbol (format "~a/opter" (syntax-e #'for))))])
|
||||
#'(begin
|
||||
(begin-for-syntax
|
||||
(reg-opter!
|
||||
#'for
|
||||
(let ([for/name (λ (opt/i opt/info stx) expr ...)])
|
||||
for/name)))
|
||||
(void)))
|
||||
(raise-syntax-error 'define/opter "expected opter name to be an identifier"
|
||||
orig-stx
|
||||
#'for))]))
|
||||
|
||||
;;
|
||||
;; opt/recursive-call
|
||||
|
|
|
|||
|
|
@ -162,14 +162,14 @@
|
|||
(that (opt/info-that opt/info)))
|
||||
(build-optres
|
||||
#:exp
|
||||
(syntax (if (and (number? val) (<= n val m))
|
||||
(syntax (if (and (real? val) (<= n val m))
|
||||
val
|
||||
(raise-opt-between/c-error
|
||||
blame val n m)))
|
||||
#:lifts lifts3
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat (syntax (and (number? val) (<= n val m)))
|
||||
#:flat (syntax (and (real? val) (<= n val m)))
|
||||
#:opt #f
|
||||
#:stronger-ribs
|
||||
(list (new-stronger-var
|
||||
|
|
@ -185,7 +185,8 @@
|
|||
[that that])
|
||||
(syntax (<= this that))))))
|
||||
#:chaperone #t
|
||||
#:name #''(between/c n m))))))]))
|
||||
#:name #''(between/c n m))))))]
|
||||
[_ (opt/unknown opt/i opt/info stx)]))
|
||||
|
||||
(define (raise-opt-between/c-error blame val lo hi)
|
||||
(raise-blame-error
|
||||
|
|
@ -194,8 +195,9 @@
|
|||
'(expected: "a number between ~a and ~a" given: "~e")
|
||||
lo hi val))
|
||||
|
||||
(define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg name)
|
||||
(with-syntax ([comparison comparison])
|
||||
(define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg name predicate?)
|
||||
(with-syntax ([comparison comparison]
|
||||
[predicate? predicate?])
|
||||
(let*-values ([(lift-low lifts2) (lift/binding arg 'single-comparison-val empty-lifts)])
|
||||
(with-syntax ([m lift-low])
|
||||
(let ([lifts3 (lift/effect (check-arg #'m) lifts2)])
|
||||
|
|
@ -207,13 +209,13 @@
|
|||
(build-optres
|
||||
#:exp
|
||||
(syntax
|
||||
(if (and (real? val) (comparison val m))
|
||||
(if (and (predicate? val) (comparison val m))
|
||||
val
|
||||
(raise-opt-single-comparison-opter-error blame val comparison m)))
|
||||
(raise-opt-single-comparison-opter-error blame val comparison m predicate?)))
|
||||
#:lifts lifts3
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat (syntax (and (number? val) (comparison val m)))
|
||||
#:flat (syntax (and (predicate? val) (comparison val m)))
|
||||
#:opt #f
|
||||
#:stronger-ribs
|
||||
(list (new-stronger-var
|
||||
|
|
@ -225,11 +227,14 @@
|
|||
#:chaperone #t
|
||||
#:name #`'(#,name m))))))))
|
||||
|
||||
(define (raise-opt-single-comparison-opter-error blame val comparison m)
|
||||
(define (raise-opt-single-comparison-opter-error blame val comparison m predicate?)
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
'(expected: "a number ~a ~a" given: "~e")
|
||||
'(expected: "a ~anumber ~a ~a" given: "~e")
|
||||
(if (equal? predicate? real?)
|
||||
"real "
|
||||
"")
|
||||
(object-name comparison) m val))
|
||||
|
||||
|
||||
|
|
@ -243,7 +248,8 @@
|
|||
#'(check-unary-between/c '=/c m)))
|
||||
#'=
|
||||
#'x
|
||||
'=/c)]))
|
||||
'=/c
|
||||
#'number?)]))
|
||||
|
||||
(define/opter (>=/c opt/i opt/info stx)
|
||||
(syntax-case stx (>=/c)
|
||||
|
|
@ -255,7 +261,8 @@
|
|||
#'(check-unary-between/c '>=/c m)))
|
||||
#'>=
|
||||
#'low
|
||||
'>=/c)]))
|
||||
'>=/c
|
||||
#'real?)]))
|
||||
|
||||
(define/opter (<=/c opt/i opt/info stx)
|
||||
(syntax-case stx (<=/c)
|
||||
|
|
@ -267,7 +274,8 @@
|
|||
#'(check-unary-between/c '<=/c m)))
|
||||
#'<=
|
||||
#'high
|
||||
'<=/c)]))
|
||||
'<=/c
|
||||
#'real?)]))
|
||||
|
||||
(define/opter (>/c opt/i opt/info stx)
|
||||
(syntax-case stx (>/c)
|
||||
|
|
@ -279,7 +287,8 @@
|
|||
#'(check-unary-between/c '>/c m)))
|
||||
#'>
|
||||
#'low
|
||||
'>/c)]))
|
||||
'>/c
|
||||
#'real?)]))
|
||||
|
||||
(define/opter (</c opt/i opt/info stx)
|
||||
(syntax-case stx (</c)
|
||||
|
|
@ -291,7 +300,8 @@
|
|||
#'(check-unary-between/c '</c m)))
|
||||
#'<
|
||||
#'high
|
||||
'</c)]))
|
||||
'</c
|
||||
#'real?)]))
|
||||
|
||||
(define/opter (cons/c opt/i opt/info stx)
|
||||
(define (opt/cons-ctc hdp tlp)
|
||||
|
|
@ -398,6 +408,46 @@
|
|||
[(_ content) (opt/listof-ctc #'content #t opt/i opt/info)]))
|
||||
|
||||
|
||||
(define-for-syntax (predicate/c-optres opt/info)
|
||||
(build-optres
|
||||
#:exp
|
||||
(with-syntax ((val (opt/info-val opt/info))
|
||||
(ctc (opt/info-contract opt/info))
|
||||
(blame (opt/info-blame opt/info)))
|
||||
(syntax (if (struct-predicate-procedure? val)
|
||||
val
|
||||
(if (procedure? val)
|
||||
(let ([exact-proc
|
||||
(case-lambda
|
||||
[(dom-arg)
|
||||
(values
|
||||
(case-lambda
|
||||
[(rng-arg)
|
||||
(if (boolean? rng-arg)
|
||||
rng-arg
|
||||
(raise-opt/pred-error blame val 'boolean?))]
|
||||
[args
|
||||
(bad-number-of-results blame val 1 args)])
|
||||
dom-arg)]
|
||||
[args
|
||||
(bad-number-of-arguments blame val args 1)])])
|
||||
(if (and (equal? (procedure-arity val) 1)
|
||||
(let-values ([(a b) (procedure-keywords val)])
|
||||
(null? b)))
|
||||
(chaperone-procedure val exact-proc)
|
||||
(if (procedure-arity-includes? val 1)
|
||||
(handle-non-exact-procedure val 1 blame exact-proc)
|
||||
(raise-flat-arrow-err blame val 1))))
|
||||
(raise-flat-arrow-err blame val 1)))))
|
||||
#:lifts null
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat #'(or (struct-predicate-procedure? val) (and (procedure? val) (procedure-arity-includes? val 1)))
|
||||
#:opt #f
|
||||
#:stronger-ribs null
|
||||
#:chaperone #t
|
||||
#:name #''predicate/c))
|
||||
|
||||
;;
|
||||
;; arrow opter
|
||||
;;
|
||||
|
|
@ -570,7 +620,7 @@
|
|||
#,@names
|
||||
'any))))
|
||||
|
||||
(syntax-case* stx (-> values any any/c) module-or-top-identifier=?
|
||||
(syntax-case* stx (-> values any any/c boolean?) module-or-top-identifier=?
|
||||
[(-> any/c ... any)
|
||||
(with-syntax ([n (- (length (syntax->list stx)) 2)])
|
||||
(build-optres
|
||||
|
|
@ -578,17 +628,20 @@
|
|||
(with-syntax ((val (opt/info-val opt/info))
|
||||
(ctc (opt/info-contract opt/info))
|
||||
(blame (opt/info-blame opt/info)))
|
||||
(syntax (if (procedure-arity-includes? val n)
|
||||
(syntax (if (and (procedure? val)
|
||||
(procedure-arity-includes? val n))
|
||||
val
|
||||
(raise-flat-arrow-err blame val n))))
|
||||
#:lifts null
|
||||
#:superlifts null
|
||||
#:partials null
|
||||
#:flat #'(procedure-arity-includes? val n)
|
||||
#:flat #'(and (procedure? val) (procedure-arity-includes? val n))
|
||||
#:opt #f
|
||||
#:stronger-ribs null
|
||||
#:chaperone #t
|
||||
#:name #`'(-> #,@(build-list (syntax-e #'n) (λ (x) 'any/c)) any)))]
|
||||
[(-> any/c boolean?)
|
||||
(predicate/c-optres opt/info)]
|
||||
[(-> dom ... (values rng ...))
|
||||
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
|
||||
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
|
||||
|
|
@ -622,6 +675,8 @@
|
|||
#:name name)
|
||||
(opt/unknown opt/i opt/info stx))))]))
|
||||
|
||||
(define/opter (predicate/c opt/i opt/info stx) (predicate/c-optres opt/info))
|
||||
|
||||
(define (handle-non-exact-procedure val dom-len blame exact-proc)
|
||||
(check-procedure val #f dom-len 0 '() '() blame)
|
||||
(chaperone-procedure
|
||||
|
|
|
|||
|
|
@ -199,20 +199,22 @@
|
|||
'(begin ,sexp (void)))))
|
||||
|
||||
(define (test-flat-contract contract pass fail)
|
||||
(define (run-three-tests contract)
|
||||
(contract-eval `(,test #t flat-contract? ,contract))
|
||||
(define (run-two-tests maybe-rewrite)
|
||||
(let ([name (if (pair? contract)
|
||||
(car contract)
|
||||
contract)])
|
||||
(contract-eval `(,test #t flat-contract? ,contract))
|
||||
(test/spec-failed (format "~a fail" name)
|
||||
`(contract ,contract ',fail 'pos 'neg)
|
||||
'pos)
|
||||
(test/spec-passed/result
|
||||
(format "~a pass" name)
|
||||
`(contract ,contract ',pass 'pos 'neg)
|
||||
pass)))
|
||||
(run-three-tests contract)
|
||||
(let/ec k (run-three-tests (rewrite contract k))))
|
||||
(let/ec k
|
||||
(test/spec-failed (format "~a fail" name)
|
||||
(maybe-rewrite `(contract ,contract ',fail 'pos 'neg) k)
|
||||
'pos))
|
||||
(let/ec k
|
||||
(test/spec-passed/result
|
||||
(format "~a pass" name)
|
||||
(maybe-rewrite `(contract ,contract ',pass 'pos 'neg) k)
|
||||
pass))))
|
||||
(run-two-tests (λ (x k) x))
|
||||
(run-two-tests rewrite))
|
||||
|
||||
(define-syntax (test-name stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -1204,6 +1206,10 @@
|
|||
(make-keyword-procedure void)
|
||||
'pos 'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'contract-arrow-non-function
|
||||
'(contract (-> any/c any) 1 'pos 'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-all-kwds2
|
||||
'((contract (-> #:a string? void?)
|
||||
|
|
@ -11562,27 +11568,25 @@
|
|||
;; evaluates the exp and returns the number of opt/c warnings found
|
||||
(contract-eval
|
||||
'(define (eval-and-count-log-messages exp)
|
||||
(define my-logger (make-logger))
|
||||
(parameterize ([current-logger my-logger])
|
||||
(define ans (make-channel))
|
||||
(define recv (make-log-receiver my-logger 'warning))
|
||||
(thread
|
||||
(λ ()
|
||||
(let loop ([opt/c-msgs 0])
|
||||
(define res (sync recv))
|
||||
(cond
|
||||
[(equal? "done" (vector-ref res 1))
|
||||
(channel-put ans opt/c-msgs)]
|
||||
[else
|
||||
(define opt/c-msg? (regexp-match? #rx"opt/c" (vector-ref res 1)))
|
||||
(loop (if opt/c-msg?
|
||||
(+ opt/c-msgs 1)
|
||||
opt/c-msgs))]))))
|
||||
(let/ec k
|
||||
(parameterize ([error-escape-handler k])
|
||||
(eval exp)))
|
||||
(log-warning "done")
|
||||
(channel-get ans))))
|
||||
(define ans (make-channel))
|
||||
(define recv (make-log-receiver (current-logger) 'warning))
|
||||
(thread
|
||||
(λ ()
|
||||
(let loop ([opt/c-msgs 0])
|
||||
(define res (sync recv))
|
||||
(cond
|
||||
[(equal? "done" (vector-ref res 1))
|
||||
(channel-put ans opt/c-msgs)]
|
||||
[else
|
||||
(define opt/c-msg? (regexp-match? #rx"opt/c" (vector-ref res 1)))
|
||||
(loop (if opt/c-msg?
|
||||
(+ opt/c-msgs 1)
|
||||
opt/c-msgs))]))))
|
||||
(let/ec k
|
||||
(parameterize ([error-escape-handler k])
|
||||
(eval exp)))
|
||||
(log-warning "done")
|
||||
(channel-get ans)))
|
||||
|
||||
(ctest 1 eval-and-count-log-messages
|
||||
'(let ()
|
||||
|
|
@ -12085,7 +12089,8 @@ so that propagation occurs.
|
|||
(test-flat-contract 'natural-number/c #e3 #i3.0)
|
||||
(test-flat-contract 'natural-number/c 0 -1)
|
||||
(test-flat-contract 'false/c #f #t)
|
||||
|
||||
(test-flat-contract 'contract? #f (λ (x y) 'whatever))
|
||||
|
||||
(test-flat-contract #t #t "x")
|
||||
(test-flat-contract #f #f "x")
|
||||
(test-flat-contract #\a #\a #\b)
|
||||
|
|
@ -12184,7 +12189,14 @@ so that propagation occurs.
|
|||
(let ([ht (make-hash)])
|
||||
(hash-set! ht 'x 1)
|
||||
ht))
|
||||
|
||||
|
||||
(test-flat-contract '(between/c 1 10) 3 11)
|
||||
(test-flat-contract '(between/c 1 10) 4 1+1i)
|
||||
(test-flat-contract '(<=/c 1) 0 1+1i)
|
||||
(test-flat-contract '(</c 1) 0 1+1i)
|
||||
(test-flat-contract '(>/c 1) 4 1+1i)
|
||||
(test-flat-contract '(>=/c 1) 4 1+1i)
|
||||
|
||||
(test #t 'malformed-binder
|
||||
(with-handlers ((exn? exn:fail:syntax?))
|
||||
(contract-eval '(flat-murec-contract ([(x) y]) x))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user