Skip to content
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.

Sign up for GitHub

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

Automated Resyntax fixes #1441

Open
wants to merge 20 commits into
base: master
Choose a base branch
from
Open

Automated Resyntax fixes #1441

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
20 commits
Select commit Hold shift + click to select a range
b4b1a3a
Fix 10 occurrences of `let-to-define`
resyntax-ci[bot] Mar 7, 2025
478293e
Fix 8 occurrences of `single-clause-match-to-match-define`
resyntax-ci[bot] Mar 7, 2025
569e226
Fix 1 occurrence of `define-begin0-extraction`
resyntax-ci[bot] Mar 7, 2025
715a8d1
Fix 1 occurrence of `and-match-to-match`
resyntax-ci[bot] Mar 7, 2025
76206de
Fix 3 occurrences of `zero-comparison-to-positive?`
resyntax-ci[bot] Mar 7, 2025
9b0f222
Fix 3 occurrences of `define-values-values-to-define`
resyntax-ci[bot] Mar 7, 2025
9931b81
Fix 1 occurrence of `unless-expression-in-for-loop-to-unless-keyword`
resyntax-ci[bot] Mar 7, 2025
f006b00
Fix 1 occurrence of `when-expression-in-for-loop-to-when-keyword`
resyntax-ci[bot] Mar 7, 2025
74f311c
Fix 4 occurrences of `if-begin-to-cond`
resyntax-ci[bot] Mar 7, 2025
1c29459
Fix 3 occurrences of `if-let-to-cond`
resyntax-ci[bot] Mar 7, 2025
cc314a9
Fix 1 occurrence of `define-let-to-double-define`
resyntax-ci[bot] Mar 7, 2025
73b873b
Fix 1 occurrence of `always-throwing-cond-to-when`
resyntax-ci[bot] Mar 7, 2025
59f77fd
Fix 1 occurrence of `zero-comparison-lambda-to-positive?`
resyntax-ci[bot] Mar 7, 2025
faa6a61
Fix 1 occurrence of `map-to-for`
resyntax-ci[bot] Mar 7, 2025
998b89b
Fix 5 occurrences of `define-lambda-to-define`
resyntax-ci[bot] Mar 7, 2025
506cef5
Fix 2 occurrences of `inline-unnecessary-define`
resyntax-ci[bot] Mar 7, 2025
16d4445
Fix 1 occurrence of `for/fold-with-conditional-body-to-unless-keyword`
resyntax-ci[bot] Mar 7, 2025
7f45b20
Fix 1 occurrence of `inline-unnecessary-begin`
resyntax-ci[bot] Mar 7, 2025
32d2a82
Fix 1 occurrence of `inverted-when`
resyntax-ci[bot] Mar 7, 2025
eb5463d
Fix 1 occurrence of `inverted-unless`
resyntax-ci[bot] Mar 7, 2025
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
56 changes: 27 additions & 29 deletions typed-racket-lib/typed-racket/private/parse-type.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -183,8 +183,8 @@
;; (Syntax -> Type) -> Syntax Any -> Syntax
;; See `parse-type/id`. This is a curried generalization.
(define ((parse/id p) loc datum)
(let* ([stx* (datum->syntax loc datum loc loc)])
(p stx*)))
(define stx* (datum->syntax loc datum loc loc))
(p stx*))

(define (parse-literal-alls stx)
(syntax-parse stx
Expand Down Expand Up @@ -831,12 +831,11 @@
refinement-type]
[(:Instance^ t)
(let ([v (do-parse #'t)])
(if (not (or (F? v) (Mu? v) (Name? v) (Class? v) (Error? v)))
(begin (parse-error #:delayed? #t
"expected a class type for argument to Instance"
"given" v)
(make-Instance (Un)))
(make-Instance v)))]
(cond
[(not (or (F? v) (Mu? v) (Name? v) (Class? v) (Error? v)))
(parse-error #:delayed? #t "expected a class type for argument to Instance" "given" v)
(make-Instance (Un))]
[else (make-Instance v)]))]
[(:Unit^ (:import^ import:id ...)
(:export^ export:id ...)
(~optional (:init-depend^ init-depend:id ...)
Expand Down Expand Up @@ -902,15 +901,16 @@
(k Err)
(remove-duplicates res)))
([ty (in-syntax #'(tys ...))])
(let ([t (do-parse ty)])
(match (resolve t)
[(Fun: arrows) (values (append res arrows) err?)]
[_ (if (side-effect-mode? mode)
(values res #t)
(parse-error
#:stx ty
"expected a function type for component of case-> type"
"given" t))]))))
(define t (do-parse ty))
(match (resolve t)
[(Fun: arrows) (values (append res arrows) err?)]
[_
(if (side-effect-mode? mode)
(values res #t)
(parse-error #:stx ty
"expected a function type for component of case-> type"
"given"
t))])))
(make-Fun arrows))]
[(:Rec^ x:id t)
(let* ([var (syntax-e #'x)])
Expand Down Expand Up @@ -1401,8 +1401,7 @@
[_ (apply rator args^)])]))]
[(? Name?)
(resolve-app-check-error rator args^ stx)
(define app (make-App rator args^))
app]
(make-App rator args^)]
[(Error:) Err]
[_ (parse-error "bad syntax in type application: expected a type constructor"
"given a type"
Expand Down Expand Up @@ -1507,10 +1506,9 @@
;; Merge all the non-duplicate entries from the parent types
(define (merge-clause parent-clause clause)
(for/fold ([clause clause])
([(k v) (in-dict parent-clause)])
(if (dict-has-key? clause k)
clause
(dict-set clause k v))))
([(k v) (in-dict parent-clause)]
#:unless (dict-has-key? clause k))
(dict-set clause k v)))

(define (match-parent-type parent-type)
(define resolved (resolve parent-type))
Expand Down Expand Up @@ -1655,12 +1653,12 @@
;; of init arguments.
(define parent-inits (get-parent-inits parent/init-type))

(define class-type
(make-Class row-var
(append given-inits parent-inits)
fields methods augments given-init-rest))

class-type]
(make-Class row-var
(append given-inits parent-inits)
fields
methods
augments
given-init-rest)]
[else
;; Conservatively assume that if there *are* #:implements
;; clauses, then the current type alias will be recursive
Expand Down
201 changes: 109 additions & 92 deletions typed-racket-lib/typed-racket/private/shallow-rewrite.rkt
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -222,36 +222,48 @@
[check-formal*
(let protect-loop ([args #'formals]
[dom* dom*])
(if (or (identifier? args)
(null? args)
(and (syntax? args) (null? (syntax-e args))))
'()
(let*-values ([(fst rst)
(cond
[(pair? args)
(values (car args) (cdr args))]
[(syntax? args)
(let ((e (syntax-e args)))
(values (car e) (cdr e)))]
[else
(raise-syntax-error 'shallow-rewrite-top "#%plain-lambda formals" #'formals args)])]
[(check*)
(let ((dom+
(for/fold ((acc '()))
((dom (in-list dom*)))
(if (pair? dom) (cons (cdr dom) acc) acc))))
(protect-loop rst dom+))]
[(fst-ty)
(let ((ann-ty (and (type-annotation fst #:infer #f) (get-type fst #:infer #t #:default Univ))))
(if (and ann-ty (not (Error? ann-ty)))
ann-ty
(apply Un (for/list ((dom (in-list dom*)) #:when (pair? dom)) (car dom)))))]
[(ex* fst+)
(if skip-dom?
(values '() #f)
(protect-domain fst-ty fst (build-source-location-list fst) ctc-cache))])
(void (register-extra-defs! ex*))
(if fst+ (cons fst+ check*) check*))))])
(cond
[(or (identifier? args)
(null? args)
(and (syntax? args) (null? (syntax-e args))))
'()]
[else
(define-values (fst rst)
(cond
[(pair? args) (values (car args) (cdr args))]
[(syntax? args)
(let ([e (syntax-e args)]) (values (car e) (cdr e)))]
[else
(raise-syntax-error 'shallow-rewrite-top
"#%plain-lambda formals"
#'formals
args)]))
(define check*
(let ([dom+ (for/fold ([acc '()]) ([dom (in-list dom*)])
(if (pair? dom)
(cons (cdr dom) acc)
acc))])
(protect-loop rst dom+)))
(define fst-ty
(let ([ann-ty (and (type-annotation fst #:infer #f)
(get-type fst #:infer #t #:default Univ))])
(if (and ann-ty (not (Error? ann-ty)))
ann-ty
(apply Un
(for/list ([dom (in-list dom*)]
#:when (pair? dom))
(car dom))))))
(define-values (ex* fst+)
(if skip-dom?
(values '() #f)
(protect-domain fst-ty
fst
(build-source-location-list fst)
ctc-cache)))
(void (register-extra-defs! ex*))
(if fst+
(cons fst+ check*)
check*)]))])
(if (null? check-formal*)
body+
(cons
Expand All @@ -272,50 +284,62 @@
;; no type
(quasisyntax/loc formals [#,formals . #,body])]
[else
(define len (formals-length formals))
(define matching-dom*
(let ([len (formals-length formals)])
(for/list ((dom (in-list all-dom*))
#:when (= len (length dom)))
dom)))
(for/list ([dom (in-list all-dom*)]
#:when (= len (length dom)))
dom))
(quasisyntax/loc stx
[#,formals .
#,(let* ([body+
(copy-props (loop body #f trusted-fn*) body)]
[check-formal*
(let protect-loop ([args formals]
[dom* matching-dom*])
(if (or (identifier? args)
(null? args)
(and (syntax? args) (null? (syntax-e args))))
'()
(let*-values ([(fst rst)
(cond
[(pair? args)
(values (car args) (cdr args))]
[(syntax? args)
(let ((e (syntax-e args)))
(values (car e) (cdr e)))]
[else
(raise-syntax-error 'shallow-rewrite-top "#%plain-lambda formals" formals args)])]
[(check*)
(let ((dom+
(for/fold ((acc '()))
((dom (in-list dom*)))
(if (pair? dom) (cons (cdr dom) acc) acc))))
(protect-loop rst dom+))]
[(fst-ty)
(if (type-annotation fst #:infer #f)
(get-type fst #:infer #t #:default Univ)
(apply Un
(for/fold ((acc '()))
((dom (in-list dom*)))
(if (pair? dom) (cons (car dom) acc) acc))))]
[(ex* fst+)
(if skip-dom?
(values '() #f)
(protect-domain fst-ty fst (build-source-location-list fst) ctc-cache))])
(void (register-extra-defs! ex*))
(if fst+ (cons fst+ check*) check*))))])
(cond
[(or (identifier? args)
(null? args)
(and (syntax? args) (null? (syntax-e args))))
'()]
[else
(define-values (fst rst)
(cond
[(pair? args) (values (car args) (cdr args))]
[(syntax? args)
(let ([e (syntax-e args)])
(values (car e) (cdr e)))]
[else
(raise-syntax-error 'shallow-rewrite-top
"#%plain-lambda formals"
formals
args)]))
(define check*
(let ([dom+ (for/fold ([acc '()])
([dom (in-list dom*)])
(if (pair? dom)
(cons (cdr dom) acc)
acc))])
(protect-loop rst dom+)))
(define fst-ty
(if (type-annotation fst #:infer #f)
(get-type fst #:infer #t #:default Univ)
(apply Un
(for/fold ([acc '()])
([dom (in-list dom*)])
(if (pair? dom)
(cons (car dom) acc)
acc)))))
(define-values (ex* fst+)
(if skip-dom?
(values '() #f)
(protect-domain fst-ty
fst
(build-source-location-list fst)
ctc-cache)))
(void (register-extra-defs! ex*))
(if fst+
(cons fst+ check*)
check*)]))])
(if (null? check-formal*)
body+
(cons
Expand Down Expand Up @@ -415,19 +439,19 @@
stx)

(define (maybe-add-typeof-expr new-stx old-stx)
(let ((old-type (maybe-type-of old-stx)))
(when old-type
(add-typeof-expr new-stx old-type))))
(define old-type (maybe-type-of old-stx))
(when old-type
(add-typeof-expr new-stx old-type)))

(define (maybe-add-test-position new-stx old-stx)
(maybe-add-test-true new-stx old-stx)
(maybe-add-test-false new-stx old-stx)
(void))

(define (maybe-add-scoped-tvar new-stx old-stx)
(let ([old-layer (lookup-scoped-tvar-layer old-stx)])
(when old-layer
(add-scoped-tvars new-stx old-layer))))
(define old-layer (lookup-scoped-tvar-layer old-stx))
(when old-layer
(add-scoped-tvars new-stx old-layer)))

(define (maybe-add-test-true new-stx old-stx)
(when (test-position-takes-true-branch old-stx)
Expand All @@ -449,20 +473,15 @@

(define (formals-fold init f stx)
(let loop ((v stx))
(if (or (identifier? v)
(null? v)
(and (syntax? v) (null? (syntax-e v))))
init
(let*-values (((fst rst)
(cond
[(pair? v)
(values (car v) (cdr v))]
[(syntax? v)
(let ((e (syntax-e v)))
(values (car e) (cdr e)))]
[else
(raise-syntax-error 'formals-fold "lambda formals" stx)])))
(f (loop rst) fst)))))
(cond
[(or (identifier? v) (null? v) (and (syntax? v) (null? (syntax-e v)))) init]
[else
(define-values (fst rst)
(cond
[(pair? v) (values (car v) (cdr v))]
[(syntax? v) (let ([e (syntax-e v)]) (values (car e) (cdr e)))]
[else (raise-syntax-error 'formals-fold "lambda formals" stx)]))
(f (loop rst) fst)])))

;; is-application? : Syntax -> Boolean
;; Returns #true if `stx` is a function application (an app that may need dynamic checking)
Expand Down Expand Up @@ -629,12 +648,10 @@
(λ (mpi)
(hash-ref! cache mpi
(λ () ;; Typed Racket always installs a `#%type-decl` submodule
(let* ([mpi+ (module-path-index-join '(submod "." #%type-decl) mpi)])
(parameterize ([current-namespace (make-base-namespace)])
(with-handlers ([exn:fail:contract? (lambda (exn) #f)])
(and mpi+
(dynamic-require mpi+ #f)
#t)))))))))
(define mpi+ (module-path-index-join '(submod "." #%type-decl) mpi))
(parameterize ([current-namespace (make-base-namespace)])
(with-handlers ([exn:fail:contract? (lambda (exn) #f)])
(and mpi+ (dynamic-require mpi+ #f) #t))))))))

(define (protect-domain dom-type dom-stx ctx ctc-cache)
(define-values [extra-def* ctc-stx]
Expand Down
Loading