make opt/c use a more comprehensive list of known-to-be-good

predicate contracts

also make it just evaporate when the contract is unknown
(instead of leaving a wrapper behind around the contract)

collects/racket/contract/private/basic-opters.rkt

@@ -7,35 +7,6 @@
 (require (for-syntax racket/base
                      "opt-guts.rkt"))
 
-;;
-;; opt/pred helper
-;;
-(define-for-syntax (opt/pred opt/info pred #:name [name (syntax-e pred)])
-  (with-syntax ((pred pred))
-    (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 (pred val)
-                   val
-                   (raise-opt/pred-error blame val 'pred))))
-     #:lifts null
-     #:superlifts null
-     #:partials null
-     #:flat (syntax (pred val))
-     #:opt #f
-     #:stronger-ribs null
-     #:chaperone #t
-     #:name #`'#,name)))
-
-(define (raise-opt/pred-error blame val pred-name)
-  (raise-blame-error
-   blame
-   val
-   '(expected: "~a")
-   pred-name))
-
 ;;
 ;; built-in predicate opters
 ;;

collects/racket/contract/private/helpers.rkt

@@ -164,6 +164,8 @@
 #|
 
 ;; the code below builds the known-good-syms-ht
+;; it should contain only predicates or else 
+;; opt/c will misbehave
 
 (define cm
   (parameterize ([read-accept-compiled #t])
@@ -366,5 +368,5 @@
 (define (known-good-contract? id)
   (define r-id (syntax-e id))
   (and (symbol? r-id)
-       (hash-ref known-good-syms-ht (syntax-e id) #t)
+       (hash-ref known-good-syms-ht r-id #f)
        (free-identifier=? id (datum->syntax #'here r-id))))

collects/racket/contract/private/opt-guts.rkt

@@ -38,7 +38,8 @@
          build-optres
          
          combine-two-chaperone?s
-         combine-two-no-negative-blame)
+         combine-two-no-negative-blame
+         log-unknown-contract-warning)
 
 ;; (define/opter (<contract-combinator> opt/i opt/info stx) body)
 ;;
@@ -248,13 +249,7 @@
 ;; opt/unknown : opt/i id id syntax
 ;;
 (define (opt/unknown opt/i opt/info uctc [extra-warning ""])
-  (log-warning (string-append (format "warning in ~a:~a: opt/c doesn't know the contract ~s" 
+  (log-unknown-contract-warning uctc extra-warning)
-                                      (syntax-source uctc)
-                                      (if (syntax-line uctc)
-                                          (format "~a:~a" (syntax-line uctc) (syntax-column uctc))
-                                          (format ":~a" (syntax-position uctc)))
-                                      (syntax->datum uctc))
-                              extra-warning))
   (with-syntax ([(lift-var partial-var partial-flat-var)
                  (generate-temporaries '(lift partial partial-flat))]
                 [val (opt/info-val opt/info)]
@@ -282,6 +277,15 @@
      #:chaperone #'(chaperone-contract? lift-var)
      #:name #'(contract-name lift-var))))
 
+(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)))
+
 
 (define opt-error-name (make-parameter 'opt/c))
 

collects/racket/contract/private/opt.rkt

@@ -2,15 +2,18 @@
 (require "prop.rkt"
          "misc.rkt"
          "blame.rkt"
+         "guts.rkt"
          racket/stxparam)
-(require (for-syntax racket/base)
+(require (for-syntax racket/base 
-         (for-syntax "opt-guts.rkt")
+                     "helpers.rkt"
-         (for-syntax racket/stxparam))
+                     "opt-guts.rkt"
+                     racket/stxparam))
 
 (provide opt/c define-opt/c define/opter
-         opt/direct
+         opt/direct 
          begin-lifted
          (for-syntax
+          opt/pred
           define-opt/recursive-fn?
           define-opt/recursive-fn-neg-blame?-id))
 
@@ -106,7 +109,8 @@
 
 ;; opt/i : id opt/info syntax ->
 ;;         syntax syntax-list syntax-list (union syntax #f) (union syntax #f)
-(define-for-syntax (opt/i opt/info stx)
+;;  if call-opt/unknown is #f, then this may just return #f instead of an optres
+(define-for-syntax (opt/i opt/info stx #:call-opt/unknown? [call-opt/unknown? #t])
   ;; the case dispatch here must match what top-level-unknown? is doing
   (syntax-case stx ()
     [(ctc arg ...)
@@ -115,6 +119,9 @@
     [argless-ctc
      (and (identifier? #'argless-ctc) (opter #'argless-ctc))
      ((opter #'argless-ctc) opt/i opt/info stx)]
+    [predicate?
+     (and (identifier? #'predicate?) (known-good-contract? #'predicate?))
+     (opt/pred opt/info #'predicate?)]
     [(f arg ...)
      (and (identifier? #'f) 
           (define-opt/recursive-fn? (syntax-local-value #'f (λ () #f))))
@@ -143,8 +150,13 @@
     [konst
      (coerecable-constant? #'konst)
      (opt-constant-contract (syntax->datum #'konst) opt/info)]
-    [else
+    [_
-     (opt/unknown opt/i opt/info stx)]))
+     (cond
+       [call-opt/unknown?
+        (opt/unknown opt/i opt/info stx)]
+       [else
+        (log-unknown-contract-warning stx)
+        #f])]))
 
 ;; top-level-unknown? : syntax -> boolean
 ;; this must match what opt/i is doing
@@ -156,6 +168,9 @@
     [argless-ctc
      (and (identifier? #'argless-ctc) (opter #'argless-ctc))
      #f]
+    [predicate?
+     (and (identifier? #'predicate?) (known-good-contract? #'predicate?))
+     #f]
     [konst
      (coerecable-constant? #'konst)
      #f]
@@ -166,6 +181,34 @@
     [else
      #t]))
 
+(define-for-syntax (opt/pred opt/info pred #:name [name (syntax-e pred)])
+  (with-syntax ((pred pred))
+    (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 (pred val)
+                   val
+                   (raise-opt/pred-error blame val 'pred))))
+     #:lifts null
+     #:superlifts null
+     #:partials null
+     #:flat (syntax (pred val))
+     #:opt #f
+     #:stronger-ribs null
+     #:chaperone #t
+     #:name #`'#,name)))
+
+(define (raise-opt/pred-error blame val pred-name)
+  (raise-blame-error
+   blame
+   val
+   '(expected: "~a")
+   pred-name))
+
+
+
 ;; opt/c : syntax -> syntax
 ;; opt/c is an optimization routine that takes in an sexp containing
 ;; contract combinators and attempts to "unroll" those combinators to save
@@ -182,22 +225,24 @@
   
   (parameterize ([opt-error-name error-name-sym])
     (define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that))
-    (define an-optres (opt/i info exp))
+    (define an-optres (opt/i info exp #:call-opt/unknown? #f))
-    (bind-superlifts
+    (if an-optres
-     (optres-superlifts an-optres)
+        (bind-superlifts
-     (bind-lifts
+         (optres-superlifts an-optres)
-      (optres-lifts an-optres)
+         (bind-lifts
-      #`(make-opt-contract
+          (optres-lifts an-optres)
-         (λ (ctc)
+          #`(make-opt-contract
-           (λ (blame)
+             (λ (ctc)
-             #,(bind-superlifts
+               (λ (blame)
-                (optres-partials an-optres)
+                 #,(bind-superlifts
-                #`(λ (val) #,(optres-exp an-optres)))))
+                    (optres-partials an-optres)
-         #,(optres-name an-optres)
+                    #`(λ (val) #,(optres-exp an-optres)))))
-         (λ (this that) #f)
+             #,(optres-name an-optres)
-         (vector)
+             (λ (this that) #f)
-         (begin-lifted (box #f))
+             (vector)
-         #,(optres-chaperone an-optres))))))
+             (begin-lifted (box #f))
+             #,(optres-chaperone an-optres))))
+        #`(coerce-contract '#,error-name-sym #,exp))))
 
 ;; this macro optimizes 'e' as a contract,
 ;; using otherwise-id if it does not recognize 'e'.