Skip to content
Original file line number Diff line number Diff line change
Expand Up @@ -45,12 +45,15 @@
(arr-seq-sc-map f (combinator-args v))
(void))
(define (sc->contract v f)
(match v
[(arr-combinator (arr-seq args rest range))
(with-syntax ([(arg-stx ...) (map f args)]
[(rest-stx ...) (if rest #`(#:rest #,(f rest)) #'())]
[range-stx (if range #`(values #,@(map f range)) #'any)])
#'(arg-stx ... rest-stx ... . -> . range-stx))]))
(match-define (arr-combinator (arr-seq args rest range)) v)
(with-syntax ([(arg-stx ...) (map f args)]
[(rest-stx ...) (if rest
#`(#:rest #,(f rest))
#'())]
[range-stx (if range
#`(values #,@(map f range))
#'any)])
#'(arg-stx ... rest-stx ... . -> . range-stx)))
(define (sc->constraints v f)
(merge-restricts* 'chaperone (map f (arr-seq->list (combinator-args v)))))])

Expand All @@ -66,20 +69,18 @@


(define (arr-seq-sc-map f seq)
(match seq
[(arr-seq args rest range)
(arr-seq
(map (λ (a) (f a 'contravariant)) args)
(and rest (f rest 'contravariant))
(and range (map (λ (a) (f a 'covariant)) range)))]))
(match-define (arr-seq args rest range) seq)
(arr-seq (map (λ (a) (f a 'contravariant)) args)
(and rest (f rest 'contravariant))
(and range (map (λ (a) (f a 'covariant)) range))))

(define (arr-seq->list seq)
(match seq
[(arr-seq args rest range)
(append
args
(if rest (list rest) empty)
(or range empty))]))
(match-define (arr-seq args rest range) seq)
(append args
(if rest
(list rest)
empty)
(or range empty)))


(struct arr-seq (args rest range)
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -24,14 +24,12 @@
(pt-seq-map f (combinator-args v))
(void))
(define (sc->contract v f)
(match v
[(prompt-tag-combinator (pt-seq vals call-cc))
(with-syntax ([(vals-stx ...) (map f vals)]
[(call-cc-stx ...)
(if call-cc
#`(#:call/cc (values #,@(map f call-cc)))
empty)])
#'(prompt-tag/c vals-stx ... call-cc-stx ...))]))
(match-define (prompt-tag-combinator (pt-seq vals call-cc)) v)
(with-syntax ([(vals-stx ...) (map f vals)]
[(call-cc-stx ...) (if call-cc
#`(#:call/cc (values #,@(map f call-cc)))
empty)])
#'(prompt-tag/c vals-stx ... call-cc-stx ...)))
(define (sc->constraints v f)
(merge-restricts* 'chaperone (map f (pt-seq->list (combinator-args v)))))])

Expand All @@ -52,16 +50,11 @@


(define (pt-seq-map f seq)
(match seq
[(pt-seq vals call-cc)
(define (f* a) (f a 'invariant))
(pt-seq
(map f* vals)
(and call-cc (map f* call-cc)))]))
(match-define (pt-seq vals call-cc) seq)
(define (f* a)
(f a 'invariant))
(pt-seq (map f* vals) (and call-cc (map f* call-cc))))

(define (pt-seq->list seq)
(match seq
[(pt-seq vals call-cc)
(append
vals
(or call-cc empty))]))
(match-define (pt-seq vals call-cc) seq)
(append vals (or call-cc empty)))
Original file line number Diff line number Diff line change
Expand Up @@ -25,64 +25,63 @@
#:property prop:combinator-name "dep->/sc"
#:methods gen:sc
[(define (sc->contract v rec)
(match v
[(->i/sc typed-side? ids dom/scs dom-deps pre pre-deps rng/scs rng-deps)
(with-syntax ([(id ...) ids]
[(c ...) (for/list ([d/sc (in-list dom/scs)]
[dep-ids (in-list dom-deps)])
(cond
[(not (null? dep-ids))
(parameterize ([static-contract-may-contain-free-ids? #t])
(rec d/sc))]
[else (rec d/sc)]))]
[(dep ...) dom-deps]
[(r-deps ...) rng-deps]
[(p-deps ...) pre-deps])
#`(->i ([id dep c] ...)
#,@(cond
[(not pre) #'()]
[else #`(#:pre (p-deps ...)
#,(cond
[(not (null? pre-deps))
(parameterize ([static-contract-may-contain-free-ids? #t])
(rec pre))]
[else (rec pre)]))])
#,(cond
[(and typed-side? (andmap any/sc? rng-deps)) #'any]
[(null? rng-deps)
#`[_ () (values #,@(map rec rng/scs))]]
[else
(parameterize ([static-contract-may-contain-free-ids? #t])
#`[_ (r-deps ...) (values #,@(map rec rng/scs))])])))]))
(match-define (->i/sc typed-side? ids dom/scs dom-deps pre pre-deps rng/scs rng-deps) v)
(with-syntax ([(id ...) ids]
[(c ...) (for/list ([d/sc (in-list dom/scs)]
[dep-ids (in-list dom-deps)])
(cond
[(not (null? dep-ids))
(parameterize ([static-contract-may-contain-free-ids? #t])
(rec d/sc))]
[else (rec d/sc)]))]
[(dep ...) dom-deps]
[(r-deps ...) rng-deps]
[(p-deps ...) pre-deps])
#`(->i ([id dep c] ...)
#,@(cond
[(not pre) #'()]
[else
#`(#:pre (p-deps ...)
#,(cond
[(not (null? pre-deps))
(parameterize ([static-contract-may-contain-free-ids? #t])
(rec pre))]
[else (rec pre)]))])
#,(cond
[(and typed-side? (andmap any/sc? rng-deps)) #'any]
[(null? rng-deps) #`[_ () (values #,@(map rec rng/scs))]]
[else
(parameterize ([static-contract-may-contain-free-ids? #t])
#`[_ (r-deps ...) (values #,@(map rec rng/scs))])]))))
(define (sc-map v f)
(match v
[(->i/sc typed-side? ids dom/scs dom-deps pre pre-deps rng/scs rng-deps)
(->i/sc typed-side?
ids
(for/list ([d/sc (in-list dom/scs)])
(f d/sc 'contravariant))
dom-deps
(and pre (f pre 'contravariant))
pre-deps
(for/list ([r/sc (in-list rng/scs)])
(f r/sc 'covariant))
rng-deps)]))
(match-define (->i/sc typed-side? ids dom/scs dom-deps pre pre-deps rng/scs rng-deps) v)
(->i/sc typed-side?
ids
(for/list ([d/sc (in-list dom/scs)])
(f d/sc 'contravariant))
dom-deps
(and pre (f pre 'contravariant))
pre-deps
(for/list ([r/sc (in-list rng/scs)])
(f r/sc 'covariant))
rng-deps))
(define (sc-traverse v f)
(match v
[(->i/sc _ _ dom/scs _ pre _ rng/scs _)
(for ([d/sc (in-list dom/scs)])
(f d/sc 'contravariant))
(when pre (f pre 'contravariant))
(for ([r/sc (in-list rng/scs)])
(f r/sc 'covariant))]))
(match-define (->i/sc _ _ dom/scs _ pre _ rng/scs _) v)
(for ([d/sc (in-list dom/scs)])
(f d/sc 'contravariant))
(when pre
(f pre 'contravariant))
(for ([r/sc (in-list rng/scs)])
(f r/sc 'covariant)))
(define (sc-terminal-kind v) 'impersonator)
(define (sc->constraints v f)
(match v
[(->i/sc _ _ dom/scs _ pre _ rng/scs _)
(merge-restricts* 'impersonator
(append (if pre (list (f pre)) (list))
(map f rng/scs)
(map f dom/scs)))]))])
(match-define (->i/sc _ _ dom/scs _ pre _ rng/scs _) v)
(merge-restricts* 'impersonator
(append (if pre
(list (f pre))
(list))
(map f rng/scs)
(map f dom/scs))))])

(require-for-cond-contract "proposition.rkt")

Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -29,12 +29,10 @@
(define (sc->contract v f)
(match-define (exist-combinator (list names doms rngs)) v)
(parameterize ([static-contract-may-contain-free-ids? #t])
(define a
(with-syntax ([doms-stx (f doms)]
[rngs-stx (f rngs)]
[n (car names)])
#'(->i ([n doms-stx]) (_ (n) rngs-stx))))
a))
(with-syntax ([doms-stx (f doms)]
[rngs-stx (f rngs)]
[n (car names)])
#'(->i ([n doms-stx]) (_ (n) rngs-stx)))))
(define (sc->constraints v f)
(simple-contract-restrict 'flat))])

Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -146,13 +146,10 @@
(match-define (function-combinator args indices mand-kws opt-kws typed-side?) v)
(define-values (mand-args opt-args mand-kw-args opt-kw-args rest-arg range-args)
(apply split-function-args args indices))
(if (and (not rest-arg)
(null? (append mand-kw-args mand-args opt-kw-args opt-args))
typed-side?)
;; currently we only handle this trivial case
;; we could probably look at the actual kind of `range-args` as well
(if (not range-args) 'flat #f)
#f))
(and (and (not rest-arg) (null? (append mand-kw-args mand-args opt-kw-args opt-args)) typed-side?)
;; currently we only handle this trivial case
;; we could probably look at the actual kind of `range-args` as well
(if (not range-args) 'flat #f)))


(define (function-sc-constraints v f)
Expand Down
Loading
Loading