Make better interface for properties with only booleans.
This commit is contained in:
Eric Dobson
parent
15fddbafe0
commit
fced81a541
|
|
@ -89,9 +89,6 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
|||
[typed-racket/private/type-contract (type->contract type->contract-fail)]
|
||||
[typed-racket/env/type-name-env (register-type-name)]))
|
||||
|
||||
(define-for-syntax (ignore stx) (ignore-property stx #t))
|
||||
(define-for-syntax (ignore-some stx) (ignore-some-property stx #t))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-class opt-parent
|
||||
#:attributes (nm parent)
|
||||
|
|
@ -281,7 +278,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
|||
#`(#%expression
|
||||
(ann
|
||||
#,(ignore-some
|
||||
#`(let-values (((val) #,(with-type-property #'(ann v Any) #t)))
|
||||
#`(let-values (((val) #,(with-type #'(ann v Any))))
|
||||
(contract
|
||||
#,ctc-expr
|
||||
val
|
||||
|
|
@ -506,12 +503,12 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
|||
[(_ ([pred? action] ...) . body)
|
||||
(with-syntax ([(pred?* ...)
|
||||
(for/list ([s (in-syntax #'(pred? ...))])
|
||||
(with-type-property #`(ann #,s : (Any -> Any)) #t))]
|
||||
(with-type #`(ann #,s : (Any -> Any))))]
|
||||
[(action* ...)
|
||||
(for/list ([s (in-syntax #'(action ...))])
|
||||
(exn-handler-property s #t))]
|
||||
[body* (exn-body-property #'(let-values () . body) #t)])
|
||||
(with-handlers-property #'(with-handlers ([pred?* action*] ...) body*) #t))]))
|
||||
(exn-handler s))]
|
||||
[body* (exn-body #'(let-values () . body))])
|
||||
(exn-handlers #'(with-handlers ([pred?* action*] ...) body*)))]))
|
||||
|
||||
(begin-for-syntax
|
||||
(define-syntax-class dtsi-struct-name
|
||||
|
|
@ -527,7 +524,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
|
|||
(syntax-parse stx #:literals (:)
|
||||
[(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty])
|
||||
(with-syntax*
|
||||
([proc* (with-type-property #'(ann proc : proc-ty) #t)]
|
||||
([proc* (with-type #'(ann proc : proc-ty))]
|
||||
[d-s (ignore-some (syntax/loc stx (define-struct nm (fld.name ...)
|
||||
#:property prop:procedure proc*)))]
|
||||
[dtsi (quasisyntax/loc stx (dtsi/exec* () nm (fld ...) proc-ty))])
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@
|
|||
#:literal-sets (kernel-literals)
|
||||
#:attributes (opt)
|
||||
;; Can't optimize this code because it isn't typechecked
|
||||
(pattern (~or opt:ignore^ opt:ignore-some^ opt:with-handlers^))
|
||||
(pattern (~or opt:ignore^ opt:ignore-some^ opt:exn-handlers^))
|
||||
|
||||
;; Can't optimize the body of this code because it isn't typechecked
|
||||
(pattern (~and _:kw-lambda^
|
||||
|
|
|
|||
|
|
@ -3,53 +3,67 @@
|
|||
syntax/parse
|
||||
(for-syntax racket/base syntax/parse racket/syntax))
|
||||
|
||||
(define-syntax define-matcher
|
||||
(syntax-parser
|
||||
[(_ name:id prop:id)
|
||||
#'(define-syntax-class name
|
||||
#:attributes (value)
|
||||
(pattern e
|
||||
#:attr value (prop #'e)
|
||||
#:when (attribute value)))]))
|
||||
|
||||
(define-syntax (define-properties stx)
|
||||
(define-syntax-class clause
|
||||
(pattern (name:id sym:id #:mark)
|
||||
#:with syntax-class-name (format-id #'name "~a^" #'name)
|
||||
#:with symbol (generate-temporary #'sym)
|
||||
#:with function
|
||||
#'(λ (stx) (syntax-property stx symbol #t)))
|
||||
(pattern (root:id sym:id)
|
||||
#:with name (format-id #'root "~a-property" #'root)
|
||||
#:with syntax-class-name (format-id #'root "~a^" #'root)
|
||||
#:with symbol (generate-temporary #'sym)))
|
||||
#:with symbol (generate-temporary #'sym)
|
||||
#:with function
|
||||
#'(case-lambda
|
||||
((stx) (syntax-property stx symbol))
|
||||
((stx value) (syntax-property stx symbol value)))))
|
||||
|
||||
(syntax-parse stx
|
||||
((_ :clause ...)
|
||||
[(_ :clause ...)
|
||||
#`(begin
|
||||
(begin
|
||||
;; TODO: make this an uninterned symbol once the phasing issue of the unit
|
||||
;; tests is fixed
|
||||
(define symbol 'sym)
|
||||
(provide name syntax-class-name)
|
||||
(define name
|
||||
(case-lambda
|
||||
((stx) (syntax-property stx symbol))
|
||||
((stx value) (syntax-property stx symbol value))))
|
||||
;; TODO: make this an uninterned symbol once the phasing issue of the unit
|
||||
;; tests is fixed
|
||||
(define symbol 'sym)
|
||||
(provide name syntax-class-name)
|
||||
(define name function)
|
||||
(define-syntax-class syntax-class-name
|
||||
#:attributes (value)
|
||||
(pattern e
|
||||
#:attr value (name #'e)
|
||||
#:when (attribute value)))) ...))))
|
||||
#:attr value (syntax-property #'e symbol)
|
||||
#:when (attribute value)))) ...)]))
|
||||
|
||||
;;TODO add contracts on the properties
|
||||
;;TODO make better interface for properties with values of only #t
|
||||
|
||||
(define-properties
|
||||
(plambda typechecker:plambda)
|
||||
(ignore typechecker:ignore)
|
||||
(ignore-some typechecker:ignore-some)
|
||||
(ignore typechecker:ignore #:mark)
|
||||
(ignore-some typechecker:ignore-some #:mark)
|
||||
(contract-def/maker typechecker:contract-def/maker)
|
||||
(contract-def typechecker:contract-def)
|
||||
(flat-contract-def typechecker:flat-contract-def)
|
||||
(external-check typechecker:external-check)
|
||||
(with-type typechecker:with-type)
|
||||
(with-type typechecker:with-type #:mark)
|
||||
(type-ascription type-ascription)
|
||||
(type-inst type-inst)
|
||||
(type-label type-label)
|
||||
(type-dotted type-dotted)
|
||||
(exn-handler typechecker:exn-handler)
|
||||
(exn-body typechecker:exn-body)
|
||||
(with-handlers typechecker:with-handlers)
|
||||
(exn-handler typechecker:exn-handler #:mark)
|
||||
(exn-body typechecker:exn-body #:mark)
|
||||
(exn-handlers typechecker:exn-handlers #:mark)
|
||||
(struct-info struct-info)
|
||||
(opt-lambda opt-lambda)
|
||||
(kw-lambda kw-lambda)
|
||||
(tail-position typechecker:called-in-tail-position)
|
||||
(tail-position typechecker:called-in-tail-position #:mark)
|
||||
)
|
||||
|
||||
|
|
|
|||
|
|
@ -81,14 +81,13 @@
|
|||
#:typed-side #f
|
||||
#:kind kind
|
||||
(type->contract-fail typ prop))])
|
||||
(ignore-property ; should be ignored by the optimizer
|
||||
(ignore ; should be ignored by the optimizer
|
||||
(quasisyntax/loc
|
||||
stx
|
||||
(define-values (n)
|
||||
(recursive-contract
|
||||
cnt
|
||||
#,(contract-kind->keyword kind))))
|
||||
#t)))]
|
||||
#,(contract-kind->keyword kind)))))))]
|
||||
[_ (int-err "should never happen - not a define-values: ~a"
|
||||
(syntax->datum stx))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -180,7 +180,7 @@
|
|||
(syntax-parse form
|
||||
#:literal-sets (kernel-literals)
|
||||
#:literals (find-method/who)
|
||||
[stx:with-handlers^
|
||||
[stx:exn-handlers^
|
||||
(check-subforms/with-handlers/check form expected)]
|
||||
[stx:ignore-some^
|
||||
(check-subforms/ignore form)
|
||||
|
|
@ -317,11 +317,8 @@
|
|||
#:literal-sets (kernel-literals)
|
||||
#:literals (#%app lambda find-method/who)
|
||||
;;
|
||||
[stx:with-handlers^
|
||||
(let ([ty (check-subforms/with-handlers form)])
|
||||
(unless ty
|
||||
(int-err "internal error: with-handlers"))
|
||||
ty)]
|
||||
[stx:exn-handlers^
|
||||
(check-subforms/with-handlers form) ]
|
||||
[stx:ignore-some^
|
||||
(check-subforms/ignore form)
|
||||
(ret Univ)]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user