133 lines
4.0 KiB
Scheme
133 lines
4.0 KiB
Scheme
#lang scheme/base
|
|
|
|
(require "contract-guts.ss"
|
|
"contract-opt.ss"
|
|
"contract.ss")
|
|
(require (for-syntax scheme/base
|
|
"contract-opt-guts.ss"))
|
|
|
|
;;
|
|
;; opt/pred helper
|
|
;;
|
|
(define-for-syntax (opt/pred opt/info pred)
|
|
(with-syntax ((pred pred))
|
|
(values
|
|
(with-syntax ((val (opt/info-val opt/info))
|
|
(ctc (opt/info-contract opt/info))
|
|
(pos (opt/info-pos opt/info))
|
|
(src-info (opt/info-src-info opt/info))
|
|
(orig-str (opt/info-orig-str opt/info)))
|
|
(syntax (if (pred val)
|
|
val
|
|
(raise-contract-error
|
|
val
|
|
src-info
|
|
pos
|
|
orig-str
|
|
"expected <~a>, given: ~e"
|
|
((name-get ctc) ctc)
|
|
val))))
|
|
null
|
|
null
|
|
null
|
|
(syntax (pred val))
|
|
#f
|
|
null)))
|
|
|
|
;;
|
|
;; built-in predicate opters
|
|
;;
|
|
(define/opter (null? opt/i opt/info stx)
|
|
(syntax-case stx (null?)
|
|
[null? (opt/pred opt/info #'null?)]))
|
|
(define/opter (boolean? opt/i opt/info stx)
|
|
(syntax-case stx (boolean?)
|
|
[boolean? (opt/pred opt/info #'boolean?)]))
|
|
(define/opter (integer? opt/i opt/info stx)
|
|
(syntax-case stx (integer?)
|
|
[integer? (opt/pred opt/info #'integer?)]))
|
|
(define/opter (char? opt/i opt/info stx)
|
|
(syntax-case stx (char?)
|
|
[char? (opt/pred opt/info #'char?)]))
|
|
(define/opter (number? opt/i opt/info stx)
|
|
(syntax-case stx (number?)
|
|
[number? (opt/pred opt/info #'number?)]))
|
|
(define/opter (pair? opt/i opt/info stx)
|
|
(syntax-case stx (pair?)
|
|
[pair? (opt/pred opt/info #'pair?)]))
|
|
(define/opter (not opt/i opt/info stx)
|
|
(syntax-case stx (not)
|
|
[not (opt/pred opt/info #'not)]))
|
|
|
|
;;
|
|
;; any/c
|
|
;;
|
|
(define/opter (any/c opt/i opt/info stx)
|
|
(syntax-case stx (any/c)
|
|
[any/c (values
|
|
(opt/info-val opt/info)
|
|
null
|
|
null
|
|
null
|
|
#'#t
|
|
#f
|
|
null)]))
|
|
|
|
;;
|
|
;; false/c
|
|
;;
|
|
(define/opter (false/c opt/i opt/info stx)
|
|
(syntax-case stx (false/c)
|
|
[false/c (opt/pred opt/info #'not)]))
|
|
|
|
;;
|
|
;; flat-contract helper
|
|
;;
|
|
(define-for-syntax (opt/flat-ctc opt/info pred checker)
|
|
(syntax-case pred (null? number? integer? boolean? pair? not)
|
|
;; Better way of doing this?
|
|
[null? (opt/pred opt/info pred)]
|
|
[number? (opt/pred opt/info pred)]
|
|
[integer? (opt/pred opt/info pred)]
|
|
[boolean? (opt/pred opt/info pred)]
|
|
[pair? (opt/pred opt/info pred)]
|
|
[pred
|
|
(let* ((lift-vars (generate-temporaries (syntax (pred error-check))))
|
|
(lift-pred (car lift-vars)))
|
|
(with-syntax ((val (opt/info-val opt/info))
|
|
(ctc (opt/info-contract opt/info))
|
|
(pos (opt/info-pos opt/info))
|
|
(src-info (opt/info-src-info opt/info))
|
|
(orig-str (opt/info-orig-str opt/info))
|
|
(lift-pred lift-pred))
|
|
(values
|
|
(syntax (if (lift-pred val)
|
|
val
|
|
(raise-contract-error
|
|
val
|
|
src-info
|
|
pos
|
|
orig-str
|
|
"expected <~a>, given: ~e"
|
|
((name-get ctc) ctc)
|
|
val)))
|
|
(interleave-lifts
|
|
lift-vars
|
|
(list #'pred (cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)]
|
|
[(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)])))
|
|
null
|
|
null
|
|
(syntax (lift-pred val))
|
|
#f
|
|
null)))]))
|
|
|
|
;;
|
|
;; flat-contract and friends
|
|
;;
|
|
(define/opter (flat-contract opt/i opt/info stx)
|
|
(syntax-case stx (flat-contract)
|
|
[(flat-contract pred) (opt/flat-ctc opt/info #'pred 'check-flat-contract)]))
|
|
(define/opter (flat-named-contract opt/i opt/info stx)
|
|
(syntax-case stx (flat-named-contract)
|
|
[(flat-named-contract name pred) (opt/flat-ctc opt/info #'pred 'check-flat-named-contract)]))
|