You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
75 lines
2.6 KiB
Racket
75 lines
2.6 KiB
Racket
#lang racket/base
|
|
(require (for-syntax racket/base racket/syntax) sugar/define net/url)
|
|
(require-via-wormhole "../typed/sugar/coerce.rkt")
|
|
|
|
(provide+safe [->int (any/c . -> . integer?)]
|
|
[->string (any/c . -> . string?)]
|
|
[->symbol (any/c . -> . symbol?)]
|
|
[->path (any/c . -> . path?)]
|
|
[->complete-path (any/c . -> . complete-path?)]
|
|
[->url (any/c . -> . url?)]
|
|
[->list (any/c . -> . list?)]
|
|
[->vector (any/c . -> . vector?)]
|
|
[->boolean (any/c . -> . boolean?)])
|
|
|
|
;; coercion contracts & *ish predicates
|
|
;; only make sense in untyped code
|
|
;; thus they are here.
|
|
(define-syntax-rule (make-blame-handler try-proc expected-sym)
|
|
(λ(b)
|
|
(λ(x)
|
|
(with-handlers ([exn:fail? (λ(e)
|
|
(raise-blame-error
|
|
b x
|
|
'(expected: "~a" given: "~e")
|
|
expected-sym x))])
|
|
(try-proc x)))))
|
|
|
|
(provide+safe make-coercion-contract)
|
|
(define-syntax (make-coercion-contract stx)
|
|
(syntax-case stx ()
|
|
[(_ stem coerce-proc)
|
|
(with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)]
|
|
[can-be-stem? (format-id stx "can-be-~a?" #'stem)])
|
|
#'(make-contract
|
|
#:name 'coerce/stem?
|
|
#:projection (make-blame-handler coerce-proc 'can-be-stem?)))]
|
|
[(_ stem)
|
|
(with-syntax ([->stem (format-id stx "->~a" #'stem)])
|
|
#'(make-coercion-contract stem ->stem))]))
|
|
|
|
(define-syntax (define+provide-coercion-contract stx)
|
|
(syntax-case stx ()
|
|
[(_ stem)
|
|
(with-syntax ([coerce/stem? (format-id stx "coerce/~a?" #'stem)])
|
|
#'(begin
|
|
(provide+safe coerce/stem?)
|
|
(define coerce/stem? (make-coercion-contract stem))))]))
|
|
|
|
(define+provide-coercion-contract int)
|
|
(define+provide-coercion-contract string)
|
|
(define+provide-coercion-contract symbol)
|
|
(define+provide-coercion-contract path)
|
|
(define+provide-coercion-contract boolean)
|
|
(define+provide-coercion-contract list)
|
|
|
|
|
|
|
|
(define-syntax (make-*ish-predicate stx)
|
|
(syntax-case stx ()
|
|
[(_ stem)
|
|
(with-syntax ([stemish? (format-id stx "~aish?" #'stem)]
|
|
[->stem (format-id stx "->~a" #'stem)])
|
|
#`(begin
|
|
(provide+safe stemish?)
|
|
(define (stemish? x)
|
|
(with-handlers ([exn:fail? (λ(e) #f)]) (and (->stem x) #t)))))]))
|
|
|
|
(make-*ish-predicate int)
|
|
(make-*ish-predicate string)
|
|
(make-*ish-predicate symbol)
|
|
(make-*ish-predicate url)
|
|
(make-*ish-predicate complete-path)
|
|
(make-*ish-predicate path)
|
|
(make-*ish-predicate list)
|
|
(make-*ish-predicate vector) |