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

Change make-predicate/define-predicate to use flat-contract-predicate.

Browse Source 
Closes PR 14610.
This commit is contained in:
Eric Dobson 2014-06-29 15:16:08 -07:00
parent 6ecbf2c542
commit b10cb6d089
1 changed files with 10 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
View File

@ -289,9 +289,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax-parse stx (syntax-parse stx
[(_ name:id ty:expr) [(_ name:id ty:expr)
#`(begin #`(begin
#,(ignore (if (eq? (syntax-local-context) 'top-level) #,(ignore #'(define name (procedure-rename (make-predicate ty) 'name)))
#'(define name (procedure-rename (make-predicate ty) 'name))
(flat-contract-def-property #'(define name #f) #'ty)))
;; not a require, this is just the unchecked declaration syntax ;; not a require, this is just the unchecked declaration syntax
#,(internal #'(require/typed-internal name (Any -> Boolean : ty))))])) #,(internal #'(require/typed-internal name (Any -> Boolean : ty))))]))
@ -311,20 +309,21 @@ This file defines two sorts of primitives. All of them are provided into any mod
type))) type)))
#`(#,(external-check-property #'#%expression check-valid-type) #`(#,(external-check-property #'#%expression check-valid-type)
#,(ignore-some/expr name #'(Any -> Boolean : ty)))) #,(ignore-some/expr #`(flat-contract-predicate #,name) #'(Any -> Boolean : ty))))
(let ([typ (parse-type #'ty)]) (let ([typ (parse-type #'ty)])
(if (Error? typ) (if (Error? typ)
;; This code should never get run, typechecking will have an error earlier ;; This code should never get run, typechecking will have an error earlier
#`(error 'make-predicate "Couldn't parse type") #`(error 'make-predicate "Couldn't parse type")
#`(#%expression #`(#%expression
#,(ignore-some/expr #,(ignore-some/expr
(type->contract #`(flat-contract-predicate
typ #,(type->contract
;; must be a flat contract typ
#:kind 'flat ;; must be a flat contract
;; the value is not from the typed side #:kind 'flat
#:typed-side #f ;; the value is not from the typed side
(type->contract-fail typ #'ty #:ctc-str "predicate")) #:typed-side #f
(type->contract-fail typ #'ty #:ctc-str "predicate")))
#'(Any -> Boolean : ty))))))])) #'(Any -> Boolean : ty))))))]))
(define-syntax (cast stx) (define-syntax (cast stx)