495 lines
22 KiB
Scheme
495 lines
22 KiB
Scheme
(module contract-opters mzscheme
|
|
(require "contract.ss"
|
|
"contract-guts.ss"
|
|
"contract-arrow.ss"
|
|
"contract-opt.ss")
|
|
(require-for-syntax "contract-opt-guts.ss")
|
|
|
|
;; opt/between-ctc : syntax syntax syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
|
(define-for-syntax (opt/between-ctc pos stx low high op)
|
|
(let* ((lifted-vars (generate-temporaries (syntax (low high error-check))))
|
|
(lifted-low (car lifted-vars))
|
|
(lifted-high (cadr lifted-vars)))
|
|
(with-syntax ((op op)
|
|
(n lifted-low)
|
|
(m lifted-high))
|
|
(values
|
|
(with-syntax ((pos pos))
|
|
(syntax (if (and (number? val) (op n val m)) val
|
|
(raise-contract-error
|
|
val
|
|
src-info
|
|
pos
|
|
orig-str
|
|
"expected <~a>, given: ~e"
|
|
contract-name
|
|
val))))
|
|
(append (interleave-lifted
|
|
lifted-vars
|
|
(list low
|
|
high
|
|
(syntax (unless (and (number? n) (number? m))
|
|
(error 'between/c "expected two numbers for bounds, got ~e and ~e" n m)))))
|
|
(list (cons #'contract-name (syntax (cond
|
|
[(= n -inf.0) `(<=/c ,m)]
|
|
[(= m +inf.0) `(>=/c ,n)]
|
|
[(= n m) `(=/c ,n)]
|
|
[else `(between/c ,n ,m)])))))
|
|
null
|
|
(syntax (and (number? val) (op n val m)))
|
|
(make-known #t stx)))))
|
|
|
|
(define/opter (between/c opt/i pos neg stx)
|
|
(syntax-case stx (between/c)
|
|
[(between/c low high) (opt/between-ctc pos stx #'low #'high #'<=)]))
|
|
|
|
(define/opter (>/c opt/i pos neg stx)
|
|
(syntax-case stx (>/c)
|
|
[(>/c low) (opt/between-ctc #'low #'+inf.0 #'<)]))
|
|
|
|
(define/opter (>=/c opt/i pos neg stx)
|
|
(syntax-case stx (>/c)
|
|
[(>=/c low) (opt/between-ctc #'low #'+inf.0 #'<=)]))
|
|
|
|
(define/opter (</c opt/i pos neg stx)
|
|
(syntax-case stx (>/c)
|
|
[(</c high) (opt/between-ctc #'-inf.0 #'high #'<)]))
|
|
|
|
(define/opter (<=/c opt/i pos neg stx)
|
|
(syntax-case stx (>/c)
|
|
[(<=/c high) (opt/between-ctc #'-inf.0 #'high #'<=)]))
|
|
|
|
(define/opter (cons-immutable/c opt/i pos neg stx)
|
|
|
|
;; opt/cons-immutable-ctc : syntax syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
|
(define (opt/cons-immutable-ctc hdp tlp)
|
|
(let-values ([(next-hdp lifted-hdp partial-hdp flat?-hdp known?-hdp)
|
|
(opt/i pos neg hdp)]
|
|
[(next-tlp lifted-tlp partial-tlp flat?-tlp known?-tlp)
|
|
(opt/i pos neg tlp)]
|
|
[(error-check)
|
|
(car (generate-temporaries (syntax (error-check))))])
|
|
(with-syntax ((check (syntax (and (immutable? val)
|
|
(pair? val)))))
|
|
(values
|
|
(with-syntax ((pos pos)
|
|
(next-hdp next-hdp)
|
|
(next-tlp next-tlp))
|
|
(syntax (if check
|
|
(cons-immutable (let ((val (car val))) next-hdp)
|
|
(let ((val (cdr val))) next-tlp))
|
|
(raise-contract-error
|
|
val
|
|
src-info
|
|
pos
|
|
orig-str
|
|
"expected <~a>, given: ~e"
|
|
contract-name
|
|
val))))
|
|
(append
|
|
(append lifted-hdp lifted-tlp)
|
|
;; FIXME naming still broken
|
|
(list (cons #'contract-name
|
|
#''cons-immutable/c)))
|
|
(append partial-hdp partial-tlp)
|
|
(if (and flat?-hdp flat?-tlp)
|
|
(with-syntax ((flat-hdp flat?-hdp)
|
|
(flat-tlp flat?-tlp))
|
|
(syntax (if (and check
|
|
(let ((val (car val))) flat-hdp)
|
|
(let ((val (cdr val))) flat-tlp)) #t #f)))
|
|
#f)
|
|
(make-known #t stx)))))
|
|
|
|
(syntax-case stx (cons-immutable/c)
|
|
[(cons-immutable/c hdp tlp)
|
|
(opt/cons-immutable-ctc #'hdp #'tlp)]))
|
|
|
|
(define/opter (cons/c opt/i pos neg stx)
|
|
|
|
;; opt/cons-ctc : syntax syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
|
(define (opt/cons-ctc hdp tlp)
|
|
(let-values ([(next-hdp lifted-hdp partial-hdp flat?-hdp known-hdp)
|
|
(opt/i pos neg hdp)]
|
|
[(next-tlp lifted-tlp partial-tlp flat?-tlp known-tlp)
|
|
(opt/i pos neg tlp)]
|
|
[(error-check)
|
|
(car (generate-temporaries (syntax (error-check))))])
|
|
(with-syntax ((next
|
|
(with-syntax ((flat?-hdp flat?-hdp)
|
|
(flat?-tlp flat?-tlp))
|
|
(syntax
|
|
(and (pair? val)
|
|
(let ((val (car val))) flat?-hdp)
|
|
(let ((val (cdr val))) flat?-tlp))))))
|
|
(values
|
|
(with-syntax ((pos pos))
|
|
(syntax (if next
|
|
val
|
|
(raise-contract-error
|
|
val
|
|
src-info
|
|
pos
|
|
orig-str
|
|
"expected <~a>, given: ~e"
|
|
contract-name
|
|
val))))
|
|
(append
|
|
lifted-hdp lifted-tlp
|
|
(list (cons error-check
|
|
(with-syntax ((hdp (known-sexp known-hdp))
|
|
(tlp (known-sexp known-tlp))
|
|
(check (with-syntax ((flat-hdp
|
|
(cond
|
|
[(known-flag known-hdp)
|
|
(if flat?-hdp #'#t #'#f)]
|
|
[else (with-syntax ((ctc (known-sexp known-hdp)))
|
|
(syntax (flat-contract? ctc)))]))
|
|
(flat-tlp
|
|
(cond
|
|
[(known-flag known-tlp)
|
|
(if flat?-tlp #'#t #'#f)]
|
|
[else (with-syntax ((ctct (known-sexp known-tlp)))
|
|
(syntax (flat-contract? ctc)))])))
|
|
(syntax (and flat-hdp flat-tlp)))))
|
|
(syntax
|
|
(unless check
|
|
(error 'cons/c "expected two flat contracts or procedures of arity 1, got: ~e and ~e"
|
|
hdp tlp))))))
|
|
;; FIXME naming still broken
|
|
(list (cons #'contract-name
|
|
#''cons/c)))
|
|
(append partial-hdp partial-tlp)
|
|
(syntax (if next #t #f))
|
|
(make-known #t stx)))))
|
|
|
|
(syntax-case stx (cons/c)
|
|
[(cons/c hdp tlp)
|
|
(opt/cons-ctc #'hdp #'tlp)]))
|
|
|
|
;; opt/pred-ctc : (any -> boolean) -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
|
(define-for-syntax (opt/pred pos pred)
|
|
(let* ((lifted-vars (generate-temporaries (syntax (pred))))
|
|
(lifted-pred-var (car lifted-vars)))
|
|
(with-syntax ((lifted-pred lifted-pred-var))
|
|
(values
|
|
(with-syntax ((pos pos))
|
|
(syntax (if (lifted-pred val)
|
|
val
|
|
(raise-contract-error
|
|
val
|
|
src-info
|
|
pos
|
|
orig-str
|
|
"expected <~a>, given: ~e"
|
|
contract-name
|
|
val))))
|
|
(append (list (cons lifted-pred-var pred))
|
|
#;(list (cons #'contract-name (syntax
|
|
(if (object-name pred)
|
|
(object-name pred)
|
|
'???)))))
|
|
null
|
|
(syntax (lifted-pred val))
|
|
(make-known #t pred)))))
|
|
|
|
(define/opter (null? opt/i pos neg stx)
|
|
(syntax-case stx (null?)
|
|
[null? (opt/pred pos #'null?)]))
|
|
|
|
(define/opter (boolean? opt/i pos neg stx)
|
|
(syntax-case stx (boolean?)
|
|
[boolean? (opt/pred pos #'boolean?)]))
|
|
|
|
(define/opter (integer? opt/i pos neg stx)
|
|
(syntax-case stx (integer?)
|
|
[integer? (opt/pred pos #'integer?)]))
|
|
|
|
(define/opter (number? opt/i pos neg stx)
|
|
(syntax-case stx (number?)
|
|
[number? (opt/pred pos #'number?)]))
|
|
|
|
(define/opter (pair? opt/i pos neg stx)
|
|
(syntax-case stx (pair?)
|
|
[pair? (opt/pred pos #'pair?)]))
|
|
|
|
(define/opter (any/c opt/i pos neg stx)
|
|
|
|
;; opt/any-ctc : -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
|
(define opt/any-ctc
|
|
(values
|
|
#'val
|
|
(list (cons #'contract-name
|
|
#''any/c))
|
|
null
|
|
(syntax #t)
|
|
(make-known #t stx)))
|
|
|
|
(syntax-case stx (any/c)
|
|
[any/c opt/any-ctc]))
|
|
|
|
(define/opter (flat-contract opt/i pos neg stx)
|
|
|
|
;; opt/flat-ctc : (any -> boolean) -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
|
(define (opt/flat-ctc pred)
|
|
(syntax-case pred (null? number? integer? boolean? pair?)
|
|
;; Better way of doing this?
|
|
[null? (opt/pred pos pred)]
|
|
[number? (opt/pred pos pred)]
|
|
[integer? (opt/pred pos pred)]
|
|
[boolean? (opt/pred pos pred)]
|
|
[pair? (opt/pred pos pred)]
|
|
[pred
|
|
(let* ((lifted-vars (generate-temporaries (syntax (pred error-check))))
|
|
(lifted-pred (car lifted-vars)))
|
|
(with-syntax ((lifted-pred (car lifted-vars)))
|
|
(values
|
|
(with-syntax ((pos pos))
|
|
(syntax (if (lifted-pred val)
|
|
val
|
|
(raise-contract-error
|
|
val
|
|
src-info
|
|
pos
|
|
orig-str
|
|
"expected <~a>, given: ~e"
|
|
contract-name
|
|
val))))
|
|
(append (interleave-lifted
|
|
lifted-vars
|
|
(list #'pred
|
|
(syntax (unless (and (procedure? lifted-pred)
|
|
(procedure-arity-includes? lifted-pred 1))
|
|
(error 'flat-named-contract
|
|
"expected procedure of one argument, given: ~e" lifted-pred)))))
|
|
(list (cons #'contract-name (syntax
|
|
(if (object-name pred)
|
|
(object-name pred)
|
|
'???)))))
|
|
null
|
|
(syntax (lifted-pred val))
|
|
(make-known #t stx))))]))
|
|
|
|
(syntax-case stx (flat-contract)
|
|
[(flat-contract pred)
|
|
(opt/flat-ctc #'pred)]))
|
|
|
|
(define/opter (-> opt/i pos neg stx)
|
|
|
|
;; opt/arrow-ctc : list-of-syntax list-of-syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
|
(define (opt/arrow-ctc doms rngs)
|
|
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
|
|
(generate-temporaries rngs))]
|
|
[(next-doms lifted-doms partial-doms)
|
|
(let loop ([vars dom-vars]
|
|
[doms doms]
|
|
[next-doms null]
|
|
[lifted-doms null]
|
|
[partial-doms null])
|
|
(cond
|
|
[(null? doms) (values (reverse next-doms) lifted-doms partial-doms)]
|
|
[else
|
|
(let-values ([(next lifted partial flat? _)
|
|
(opt/i neg pos (car doms))])
|
|
(loop (cdr vars)
|
|
(cdr doms)
|
|
(cons (with-syntax ((next next)
|
|
(car-vars (car vars)))
|
|
(syntax (let ((val car-vars)) next)))
|
|
next-doms)
|
|
(append lifted-doms lifted)
|
|
(append partial-doms partial)))]))]
|
|
[(next-rngs lifted-rngs partial-rngs)
|
|
(let loop ([vars rng-vars]
|
|
[rngs rngs]
|
|
[next-rngs null]
|
|
[lifted-rngs null]
|
|
[partial-rngs null])
|
|
(cond
|
|
[(null? rngs) (values (reverse next-rngs) lifted-rngs partial-rngs)]
|
|
[else
|
|
(let-values ([(next lifted partial flat? _)
|
|
(opt/i pos neg (car rngs))])
|
|
(loop (cdr vars)
|
|
(cdr rngs)
|
|
(cons (with-syntax ((next next)
|
|
(car-vars (car vars)))
|
|
(syntax (let ((val car-vars)) next)))
|
|
next-rngs)
|
|
(append lifted-rngs lifted)
|
|
(append partial-rngs partial)))]))])
|
|
(values
|
|
(with-syntax (((dom-arg ...) dom-vars)
|
|
((rng-arg ...) rng-vars)
|
|
((next-dom ...) next-doms)
|
|
(dom-len (length dom-vars))
|
|
((next-rng ...) next-rngs))
|
|
(syntax (if (and (procedure? val) (procedure-arity-includes? val dom-len))
|
|
(λ (dom-arg ...)
|
|
(let-values ([(rng-arg ...) (val next-dom ...)])
|
|
(values next-rng ...)))
|
|
(error '-> "expected a procedure of arity ~a, got ~e" dom-len val))))
|
|
(append lifted-doms lifted-rngs
|
|
(list (cons #'contract-name
|
|
#''->/c)))
|
|
(append partial-doms partial-rngs)
|
|
#f
|
|
(make-known #t stx))))
|
|
|
|
;; opt/arrow-any-ctc : list-of-syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
|
(define (opt/arrow-any-ctc doms)
|
|
(let*-values ([(dom-vars) (generate-temporaries doms)]
|
|
[(next-doms lifted-doms partial-doms)
|
|
(let loop ([vars dom-vars]
|
|
[doms doms]
|
|
[next-doms null]
|
|
[lifted-doms null]
|
|
[partial-doms null])
|
|
(cond
|
|
[(null? doms) (values (reverse next-doms) lifted-doms partial-doms)]
|
|
[else
|
|
(let-values ([(next lifted partial flat? _)
|
|
(opt/i pos neg (car doms))])
|
|
(loop (cdr vars)
|
|
(cdr doms)
|
|
(cons (with-syntax ((next next)
|
|
(car-vars (car vars)))
|
|
(syntax (let ((val car-vars)) next)))
|
|
next-doms)
|
|
(append lifted-doms lifted)
|
|
(append partial-doms partial)))]))])
|
|
(values
|
|
(with-syntax (((dom-arg ...) dom-vars)
|
|
((next-dom ...) next-doms)
|
|
(dom-len (length dom-vars)))
|
|
(syntax (if (and (procedure? val) (procedure-arity-includes? val dom-len))
|
|
(λ (dom-arg ...)
|
|
(val next-dom ...))
|
|
(error '-> "expected a procedure of arity ~a, got ~e" dom-len val))))
|
|
(append lifted-doms
|
|
;; FIXME naming still broken
|
|
(list (cons #'contract-name
|
|
#''->/c)))
|
|
(append partial-doms)
|
|
#f
|
|
(make-known #t stx))))
|
|
|
|
(syntax-case stx (-> values any)
|
|
[(-> dom ... (values rng ...))
|
|
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
|
(syntax->list (syntax (rng ...))))]
|
|
[(-> dom ... any)
|
|
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
|
|
[(-> dom ... rng)
|
|
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
|
(list #'rng))]))
|
|
|
|
(define/opter (unknown opt/i pos neg stx)
|
|
|
|
;; opt/unknown-ctc : list-of-syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
|
(define (opt/unknown-ctc ctc)
|
|
(let* ((lifted-vars (generate-temporaries (syntax (lifted error-check))))
|
|
(lifted-var (car lifted-vars))
|
|
(partial-var (car (generate-temporaries (syntax (partial))))))
|
|
(values
|
|
(with-syntax ((partial-var partial-var)
|
|
(lifted-var lifted-var)
|
|
(ctc ctc))
|
|
(syntax (partial-var val)))
|
|
(append
|
|
(interleave-lifted
|
|
lifted-vars
|
|
(list ctc
|
|
(with-syntax ((lifted-var lifted-var))
|
|
(syntax
|
|
(unless (contract? lifted-var)
|
|
(error 'contract "expected contract, given ~e" lifted-var))))))
|
|
(list
|
|
(cons #'contract-name
|
|
#''opt/c)))
|
|
(list (cons
|
|
partial-var
|
|
(with-syntax ((lifted-var lifted-var)
|
|
(pos pos)
|
|
(neg neg))
|
|
(syntax (((proj-get lifted-var) lifted-var) pos neg src-info orig-str)))))
|
|
#f
|
|
(make-known #f lifted-var))))
|
|
|
|
(syntax-case stx ()
|
|
[ctc
|
|
(opt/unknown-ctc #'ctc)]))
|
|
|
|
(define/opter (or/c opt/i pos neg stx)
|
|
|
|
;; opt/or-ctc : list-of-syntax -> syntax list-of-syntax list-of-syntax boolean-or-syntax known
|
|
(define (opt/or-ctc ps)
|
|
(let ((lifted-from-hos null)
|
|
(partial-from-hos null))
|
|
(let-values ([(opt-ps lifted-ps partial-ps hos ho-ctc)
|
|
(let loop ([ps ps]
|
|
[next-ps null]
|
|
[lifted-ps null]
|
|
[partial-ps null]
|
|
[hos null]
|
|
[ho-ctc #f])
|
|
(cond
|
|
[(null? ps) (values next-ps lifted-ps partial-ps (reverse hos) ho-ctc)]
|
|
[else
|
|
(let-values ([(next lifted partial flat? _)
|
|
(opt/i pos neg (car ps))])
|
|
(if flat?
|
|
(loop (cdr ps)
|
|
(cons flat? next-ps)
|
|
(append lifted-ps lifted)
|
|
(append partial-ps partial)
|
|
hos
|
|
ho-ctc)
|
|
(if (< (length hos) 1)
|
|
(loop (cdr ps)
|
|
next-ps
|
|
(append lifted-ps lifted)
|
|
(append partial-ps partial)
|
|
(cons (car ps) hos)
|
|
next)
|
|
(loop (cdr ps)
|
|
next-ps
|
|
lifted-ps
|
|
partial-ps
|
|
(cons (car ps) hos)
|
|
ho-ctc))))]))])
|
|
(with-syntax ((next-ps (with-syntax (((opt-p ...) opt-ps))
|
|
(syntax (or #f opt-p ...)))))
|
|
(values
|
|
(cond
|
|
[(null? hos) (with-syntax ((pos pos))
|
|
(syntax
|
|
(if next-ps val
|
|
(raise-contract-error val src-info pos orig-str
|
|
"none of the branches of the or/c matched"))))]
|
|
[(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc))
|
|
(syntax
|
|
(if next-ps val ho-ctc)))]
|
|
[(> (length hos) 1)
|
|
(let-values ([(next-hos lifted-hos partial-hos _ __)
|
|
((opter 'unknown) opt/i pos neg (cons #'or/c hos))])
|
|
(set! lifted-from-hos lifted-hos)
|
|
(set! partial-from-hos partial-hos)
|
|
(with-syntax ((next-hos next-hos))
|
|
(syntax
|
|
(if next-ps val next-hos))))])
|
|
(append lifted-ps
|
|
lifted-from-hos
|
|
(list (cons #'contract-name
|
|
#''or/c-placeholder)))
|
|
(append partial-ps
|
|
partial-from-hos)
|
|
(if (null? hos)
|
|
(syntax next-ps)
|
|
#f)
|
|
(make-known #t stx))))))
|
|
|
|
(syntax-case stx (or/c)
|
|
[(or/c p ...)
|
|
(opt/or-ctc (syntax->list (syntax (p ...))))])))
|