Skip to content

Automated Resyntax fixes #1450

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
wants to merge 8 commits into
base: master
Choose a base branch
from
24 changes: 13 additions & 11 deletions typed-racket-lib/typed-racket/env/global-env.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -74,10 +74,10 @@
#:when (attribute type)))

(define (maybe-finish-register-type id)
(let ([v (free-id-table-ref the-mapping id)])
(if (box? v)
(register-type id (unbox v))
#f)))
(define v (free-id-table-ref the-mapping id))
(if (box? v)
(register-type id (unbox v))
#f))

(define (unregister-type id)
(free-id-table-remove! the-mapping id))
Expand All @@ -91,13 +91,15 @@
the-mapping
(lambda (id e)
(when (box? e)
(let ([bnd (identifier-binding id)])
(tc-error/delayed #:stx id
"Declaration for `~a' provided, but `~a' ~a"
(syntax-e id) (syntax-e id)
(cond [(eq? bnd 'lexical) "is a lexical binding"] ;; should never happen
[(not bnd) "has no definition"]
[else "is defined in another module"])))))))
(define bnd (identifier-binding id))
(tc-error/delayed #:stx id
"Declaration for `~a' provided, but `~a' ~a"
(syntax-e id)
(syntax-e id)
(cond
[(eq? bnd 'lexical) "is a lexical binding"] ;; should never happen
[(not bnd) "has no definition"]
[else "is defined in another module"]))))))

;; map over the-mapping, producing a list
;; (id type -> T) -> listof[T]
Expand Down
19 changes: 9 additions & 10 deletions typed-racket-lib/typed-racket/env/init-envs.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -331,11 +331,10 @@
[(Instance: ty) `(make-Instance ,(type->sexp ty))]
[(Signature: name extends mapping)
(define (serialize-mapping m)
(map (lambda (id/ty)
(define id (car id/ty))
(define ty (force (cdr id/ty)))
`(cons (quote-syntax ,id) ,(type->sexp ty)))
m))
(for/list ([id/ty (in-list m)])
(define id (car id/ty))
(define ty (force (cdr id/ty)))
`(cons (quote-syntax ,id) ,(type->sexp ty))))
(define serialized-extends (and extends `(quote-syntax ,extends)))
`(make-Signature (quote-syntax ,name)
,serialized-extends
Expand Down Expand Up @@ -437,11 +436,11 @@
`(make-PrefabPE (quote ,key) ,idx)]))

(define (bound-in-this-module id)
(let ([binding (identifier-binding id)])
(if (and (list? binding) (module-path-index? (car binding)))
(let-values ([(mp base) (module-path-index-split (car binding))])
(not mp))
#f)))
(define binding (identifier-binding id))
(if (and (list? binding) (module-path-index? (car binding)))
(let-values ([(mp base) (module-path-index-split (car binding))])
(not mp))
#f))

(define (make-init-code map f)
(define (bound-f id v)
Expand Down
8 changes: 4 additions & 4 deletions typed-racket-lib/typed-racket/env/type-alias-env.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -80,10 +80,10 @@
(match v
[(struct unresolved (stx _ persistent?))
(set-unresolved-in-process! v #t)
(let ([t (parse-type stx)])
(when persistent?
(mapping-put! id (make-resolved t)))
t)]
(define t (parse-type stx))
(when persistent?
(mapping-put! id (make-resolved t)))
t]
[(struct resolved (t))
t]))

Expand Down
12 changes: 6 additions & 6 deletions typed-racket-lib/typed-racket/private/shallow-rewrite.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -239,12 +239,12 @@
"#%plain-lambda formals"
#'formals
args)]))
(define check*
(let ([dom+ (for/fold ([acc '()])
([dom (in-list dom*)]
#:when (pair? dom))
(cons (cdr dom) acc))])
(protect-loop rst dom+)))
(define dom+
(for/fold ([acc '()])
([dom (in-list dom*)]
#:when (pair? dom))
(cons (cdr dom) acc)))
(define check* (protect-loop rst dom+))
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Another for/reverse

(define ann-ty
(and (type-annotation fst #:infer #f)
(get-type fst #:infer #t #:default Univ)))
Expand Down
14 changes: 5 additions & 9 deletions typed-racket-lib/typed-racket/rep/object-rep.rkt
Original file line number Diff line number Diff line change
Expand Up @@ -272,16 +272,12 @@
(if (Empty? nm)
(values c ts)
(values c (terms-set ts p (+ coeff (terms-ref ts p)))))]
[(? exact-integer? new-const)
(values (+ new-const c) ts)]
[(LExp: c* ts*)
(values (+ c c*) (add-terms ts ts*))]
[(? exact-integer? new-const) (values (+ new-const c) ts)]
[(LExp: c* ts*) (values (+ c c*) (add-terms ts ts*))]
[(list (? exact-integer? l-coeff) (? LExp? l))
(match (scale-obj l-coeff l)
[(LExp: c* ts*)
(values (+ c c*) (add-terms ts ts*))])]
[(? Object? p)
(values c (terms-set ts p (add1 (terms-ref ts p))))]
(match-define (LExp: c* ts*) (scale-obj l-coeff l))
(values (+ c c*) (add-terms ts ts*))]
[(? Object? p) (values c (terms-set ts p (add1 (terms-ref ts p))))]
[(? name-ref/c var)
(define p (-id-path var))
(values c (terms-set ts p (add1 (terms-ref ts p))))])))
Expand Down
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)]
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Should resyntax use define/with-syntax?

Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I've considered it. The opportunity doesn't seem to come up much though.

[(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)
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I really want a way to turn this formatting decision off.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This function in particular hardly seems worth defining at all.

(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 @@ -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