Automated Resyntax fixes

typed-racket-lib/typed-racket/core.rkt

@@ -48,10 +48,12 @@
                                      (and (attribute opt?) (syntax-e (attribute opt?))))]
                       [with-refinements? (and (or (attribute refinement-reasoning?)
                                                   (with-refinements?))
-                                              (when (not (eq? te-mode deep))
+                                              (unless (eq? te-mode deep)
                                                 (raise-arguments-error
-                                                  (string->symbol (format "typed/racket/~a" (keyword->string (syntax-e te-attr))))
-                                                  "#:with-refinements unsupported")))])
+                                                 (string->symbol (format "typed/racket/~a"
+                                                                         (keyword->string
+                                                                          (syntax-e te-attr))))
+                                                 "#:with-refinements unsupported")))])
          (tc-module/full te-mode stx pmb-form
           (λ (new-mod pre-before-code pre-after-code)
             (define ctc-cache (make-hash))

typed-racket-lib/typed-racket/tc-setup.rkt

@@ -36,15 +36,15 @@
   ;; types are enforced (not no-check etc.),
   ;; PLT_TR_NO_OPTIMIZE is not set, and the
   ;; current code inspector has sufficient privileges
-  (if (and (optimize?)
-           (memq (current-type-enforcement-mode) (list deep shallow))
-           (not (getenv "PLT_TR_NO_OPTIMIZE"))
-           (authorized-code-inspector?))
-      (begin
-        (do-time "Starting optimizer")
-        (begin0 (stx-map optimize-top body)
-          (do-time "Optimized")))
-      body))
+  (cond
+    [(and (optimize?)
+          (memq (current-type-enforcement-mode) (list deep shallow))
+          (not (getenv "PLT_TR_NO_OPTIMIZE"))
+          (authorized-code-inspector?))
+     (do-time "Starting optimizer")
+     (begin0 (stx-map optimize-top body)
+       (do-time "Optimized"))]
+    [else body]))
 
 (define (maybe-shallow-rewrite body-stx ctc-cache)
   (case (current-type-enforcement-mode)

typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt

@@ -213,7 +213,7 @@
                  opt:opt-lambda^)
            ;; it's only an interesting opt-lambda expansion if the number
            ;; of optional arguments is greater than zero
-           #:when (> (cadr (attribute opt.value)) 0)
+           #:when (positive? (cadr (attribute opt.value)))
            #:do [(register/method #'meth-name)]
            #:with props-core
                   (let* ([prop-val (attribute opt.value)]
@@ -290,12 +290,10 @@
       [(tc-result1: type) (resolve type)]
       [_ #f]))
   (match expected-type
-    [(? Class? class-type)
-     (ret (parse-and-check form class-type))]
+    [(? Class? class-type) (ret (parse-and-check form class-type))]
     [(Poly-names: ns body-type)
-     (match (check-class form (ret body-type))
-       [(tc-result1: t f o)
-        (ret (make-Poly ns t) f o)])]
+     (match-define (tc-result1: t f o) (check-class form (ret body-type)))
+     (ret (make-Poly ns t) f o)]
     [_ (ret (parse-and-check form #f))]))
 
 ;; Syntax Option<Type> -> Type
@@ -714,18 +712,12 @@
      (localize local-augment-table 'augment-internals)
      (localize local-inner-table '(pubment-internals augment-internals))
      (localize local-init-table 'only-init-internals)))
-  (define-values (localized-field-get-names
-                  localized-field-set-names
-                  localized-private-field-get-names
-                  localized-private-field-set-names
-                  localized-inherit-field-get-names
-                  localized-inherit-field-set-names)
-    (values (map car localized-field-pairs)
-            (map cadr localized-field-pairs)
-            (map car localized-private-field-pairs)
-            (map cadr localized-private-field-pairs)
-            (map car localized-inherit-field-pairs)
-            (map cadr localized-inherit-field-pairs)))
+  (define localized-field-get-names (map car localized-field-pairs))
+  (define localized-field-set-names (map cadr localized-field-pairs))
+  (define localized-private-field-get-names (map car localized-private-field-pairs))
+  (define localized-private-field-set-names (map cadr localized-private-field-pairs))
+  (define localized-inherit-field-get-names (map car localized-inherit-field-pairs))
+  (define localized-inherit-field-set-names (map cadr localized-inherit-field-pairs))
 
   ;; construct the types for method accessors
   (define (make-method-types method-names type-map
@@ -1317,25 +1309,25 @@
 ;; Check that by-name inits are valid for the superclass
 (define (check-by-name init-stxs super-inits)
   (match-define (super-init-stxs _ by-name) init-stxs)
-  (for ([(name _) (in-dict by-name)])
-    (unless (dict-ref super-inits name #f)
-      (tc-error/fields
-       "invalid `super-new' or `super-instantiate'"
-       #:more "init argument not accepted by superclass"
-       "init name" name
-       #:stx #`#,name
-       #:delayed? #t))))
+  (for ([(name _) (in-dict by-name)]
+        #:unless (dict-ref super-inits name #f))
+    (tc-error/fields "invalid `super-new' or `super-instantiate'"
+                     #:more "init argument not accepted by superclass"
+                     "init name"
+                     name
+                     #:stx #`#,name
+                     #:delayed? #t)))
 
 ;; check-super-new : super-init-stxs Dict Type -> Void
 ;; Check if the super-new call is well-typed
 (define (check-super-new super-new super-inits init-rest)
   (match-define (super-init-stxs provided-pos-args provided-inits)
                 super-new)
   (define pos-init-diff (- (length provided-pos-args) (length super-inits)))
-  (cond [(and (> pos-init-diff 0) (not init-rest))
+  (cond [(and (positive? pos-init-diff) (not init-rest))
          ;; errror case that's caught above, do nothing
          (void)]
-        [(> pos-init-diff 0)
+        [(positive? pos-init-diff)
          (define-values (pos-args for-init-rest)
            (split-at provided-pos-args (length super-inits)))
          (for ([pos-arg pos-args]
@@ -1361,12 +1353,9 @@
 ;; the pubment types as default augment types if an augment type
 ;; was not already provided
 (define (setup-pubment-defaults pubment-names annotations augment-annotations)
-  (for ([name pubment-names])
-    (when (and (not (hash-has-key? augment-annotations name))
-               (hash-has-key? annotations name))
-      (hash-set! augment-annotations
-                 name
-                 (dict-ref annotations name)))))
+  (for ([name pubment-names]
+        #:when (and (not (hash-has-key? augment-annotations name)) (hash-has-key? annotations name)))
+    (hash-set! augment-annotations name (dict-ref annotations name))))
 
 ;; infer-self-type : Dict RowVar Class Dict<Symbol, Type> Dict<Symbol, Type>
 ;;                   Set<Symbol> Dict<Symbol, Symbol>
@@ -1430,13 +1419,12 @@
       [(Class: _ inits fields publics augments init-rest)
        (values inits fields publics augments init-rest)]
       [_ (values #f #f #f #f #f)]))
-  (define-values (inits fields publics pubments overrides init-rest-name)
-    (values (hash-ref parse-info 'init-internals)
-            (hash-ref parse-info 'field-internals)
-            (hash-ref parse-info 'public-internals)
-            (hash-ref parse-info 'pubment-internals)
-            (hash-ref parse-info 'override-internals)
-            (hash-ref parse-info 'init-rest-name)))
+  (define inits (hash-ref parse-info 'init-internals))
+  (define fields (hash-ref parse-info 'field-internals))
+  (define publics (hash-ref parse-info 'public-internals))
+  (define pubments (hash-ref parse-info 'pubment-internals))
+  (define overrides (hash-ref parse-info 'override-internals))
+  (define init-rest-name (hash-ref parse-info 'init-rest-name))
   (define init-types (make-inits inits super-inits expected-inits))
   (define field-types (make-type-dict fields super-fields expected-fields Univ))
 

typed-racket-lib/typed-racket/typecheck/tc-app-helper.rkt

@@ -379,25 +379,34 @@
           msg-vars
           (Fun: (list (Arrow: msg-doms msg-rests kws msg-rngs) ...))
           _))
-     (let ([fcn-string (if name
-                           (format "function with keywords ~a" (syntax->datum name))
-                           "function with keywords")])
-       (if (and (andmap null? msg-doms)
-                (null? argtypes))
-           (tc-error/expr (string-append
-                           "Could not infer types for applying polymorphic "
+     (define fcn-string
+       (if name
+           (format "function with keywords ~a" (syntax->datum name))
+           "function with keywords"))
+     (if (and (andmap null? msg-doms) (null? argtypes))
+         (tc-error/expr
+          (string-append "Could not infer types for applying polymorphic " fcn-string "\n"))
+         (domain-mismatches
+          f-stx
+          args-stx
+          t
+          msg-doms
+          msg-rests
+          msg-rngs
+          argtypes
+          #f
+          #f
+          #:expected expected
+          #:msg-thunk
+          (lambda (dom)
+            (string-append "Polymorphic "
                            fcn-string
-                           "\n"))
-           (domain-mismatches f-stx args-stx t msg-doms msg-rests
-                              msg-rngs argtypes #f #f #:expected expected
-                              #:msg-thunk (lambda (dom)
-                                            (string-append
-                                             "Polymorphic " fcn-string " could not be applied to arguments:\n"
-                                             dom
-                                             (if (not (subset? (apply set-union (seteq) (map fv/list msg-doms))
-                                                               (list->seteq msg-vars)))
-                                                 (string-append "Type Variables: " (stringify msg-vars) "\n")
-                                                 ""))))))]))
+                           " could not be applied to arguments:\n"
+                           dom
+                           (if (not (subset? (apply set-union (seteq) (map fv/list msg-doms))
+                                             (list->seteq msg-vars)))
+                               (string-append "Type Variables: " (stringify msg-vars) "\n")
+                               "")))))]))
 
 ;; name->function-str : (Option Identifier) -> String
 ;; Produce a function name string for error messages

typed-racket-lib/typed-racket/typecheck/tc-envops.rkt

@@ -42,17 +42,17 @@
     [else
      (define-values (props atoms^) (combine-props ps (env-props env)))
 
-     (define atoms (if atoms^
+     (define atoms (and atoms^
                         ;; fix the order of paths to the same object.
                         ;; move objects with fewer path elements forward.
-                        (sort atoms^ (lambda (x y)
-                                       (match* (x y)
-                                         [((TypeProp: (Path: pes1 (? identifier? var1)) _)
-                                           (TypeProp: (Path: pes2 (? identifier? var2)) _))
-                                          #:when (equal? var1 var2)
-                                          (and (< (length pes1) (length pes2)))]
-                                         [(_ _) #f])))
-                        atoms^))
+                        (sort atoms^
+                              (lambda (x y)
+                                (match* (x y)
+                                  [((TypeProp: (Path: pes1 (? identifier? var1)) _)
+                                    (TypeProp: (Path: pes2 (? identifier? var2)) _))
+                                   #:when (equal? var1 var2)
+                                   (and (< (length pes1) (length pes2)))]
+                                  [(_ _) #f])))))
      (cond
        [props
         (let loop ([todo atoms]
@@ -82,35 +82,36 @@
                           (env-set-obj-type Γ obj new-t*))])))
              (match p
                [(TypeProp: (and obj (Path: pes (? identifier? x))) pt)
-                (let ([t (lookup-id-type/lexical x Γ #:fail (λ (_) Univ))])
-                  (define new-t (update t pt #t pes))
-                  (cond
-                    [(Bottom? new-t) #f]
-                    [(equal? t new-t)
-                     (cond
-                       [(ormap uninterpreted-PE? pes)
-                        (update-obj-pos-type new Γ obj pt)]
-                       [else (loop ps (cons p atoms) negs new Γ)])]
-                    [else
-                     ;; it's a new type! check if there are any logical propositions that can
-                     ;; be extracted from new-t
-                     (define-values (new-t* new-props) (extract-props (-id-path x) new-t))
-                     (cond
-                       ;; if the path contains an uninterpreted path element,
-                       ;; we need to update the object's type in addition to
-                       ;; the identifier's type
-                       [(ormap uninterpreted-PE? pes)
-                        (update-obj-pos-type (append new-props new)
-                                             (env-set-id-type Γ x new-t*)
-                                             obj
-                                             pt)]
-                       [(path-type pes new-t*) => (lambda (pt)
-                                                    (loop ps
-                                                          (cons (-is-type obj pt) atoms)
-                                                          negs
-                                                          (append new-props new)
-                                                          (env-set-id-type Γ x new-t*)))]
-                       [else #f])]))]
+                (define t (lookup-id-type/lexical x Γ #:fail (λ (_) Univ)))
+                (define new-t (update t pt #t pes))
+                (cond
+                  [(Bottom? new-t) #f]
+                  [(equal? t new-t)
+                   (cond
+                     [(ormap uninterpreted-PE? pes) (update-obj-pos-type new Γ obj pt)]
+                     [else (loop ps (cons p atoms) negs new Γ)])]
+                  [else
+                   ;; it's a new type! check if there are any logical propositions that can
+                   ;; be extracted from new-t
+                   (define-values (new-t* new-props) (extract-props (-id-path x) new-t))
+                   (cond
+                     ;; if the path contains an uninterpreted path element,
+                     ;; we need to update the object's type in addition to
+                     ;; the identifier's type
+                     [(ormap uninterpreted-PE? pes)
+                      (update-obj-pos-type (append new-props new)
+                                           (env-set-id-type Γ x new-t*)
+                                           obj
+                                           pt)]
+                     [(path-type pes new-t*)
+                      =>
+                      (lambda (pt)
+                        (loop ps
+                              (cons (-is-type obj pt) atoms)
+                              negs
+                              (append new-props new)
+                              (env-set-id-type Γ x new-t*)))]
+                     [else #f])])]
                [(TypeProp: obj pt)
                 (update-obj-pos-type new Γ obj pt)]
                ;; process negative info _after_ positive info so we don't miss anything!
@@ -145,33 +146,32 @@
                                  (env-set-obj-type Γ obj new-t*))])))
                     (match p
                       [(NotTypeProp: (and obj (Path: pes (? identifier? x))) pt)
-                       (let ([t (lookup-id-type/lexical x Γ #:fail (λ (_) Univ))])
-                         (define new-t (update t pt #f pes))
-                         (cond
-                           [(Bottom? new-t) #f]
-                           [(equal? t new-t)
-                            (cond
-                              [(ormap uninterpreted-PE? pes)
-                               (update-obj-neg-type new Γ obj pt)]
-                              [else (loop negs (cons p atoms) new Γ)])]
-                           [else
-                            ;; it's a new type! check if there are any logical propositions that can
-                            ;; be extracted from new-t
-                            (define-values (new-t* new-props) (extract-props (-id-path x) new-t))
-                            (cond
-                              ;; if the path contains an uninterpreted path element,
-                              ;; we need to update the object's type in addition to
-                              ;; the identifier's type
-                              [(ormap uninterpreted-PE? pes)
-                               (update-obj-neg-type (append new-props new)
-                                                    (env-set-id-type Γ x new-t*)
-                                                    obj
-                                                    pt)]
-                              [else
-                               (loop negs
-                                     (cons p atoms)
-                                     (append new-props new)
-                                     (env-set-id-type Γ x new-t*))])]))]
+                       (define t (lookup-id-type/lexical x Γ #:fail (λ (_) Univ)))
+                       (define new-t (update t pt #f pes))
+                       (cond
+                         [(Bottom? new-t) #f]
+                         [(equal? t new-t)
+                          (cond
+                            [(ormap uninterpreted-PE? pes) (update-obj-neg-type new Γ obj pt)]
+                            [else (loop negs (cons p atoms) new Γ)])]
+                         [else
+                          ;; it's a new type! check if there are any logical propositions that can
+                          ;; be extracted from new-t
+                          (define-values (new-t* new-props) (extract-props (-id-path x) new-t))
+                          (cond
+                            ;; if the path contains an uninterpreted path element,
+                            ;; we need to update the object's type in addition to
+                            ;; the identifier's type
+                            [(ormap uninterpreted-PE? pes)
+                             (update-obj-neg-type (append new-props new)
+                                                  (env-set-id-type Γ x new-t*)
+                                                  obj
+                                                  pt)]
+                            [else
+                             (loop negs
+                                   (cons p atoms)
+                                   (append new-props new)
+                                   (env-set-id-type Γ x new-t*))])])]
                       [(NotTypeProp: obj pt)
                        (update-obj-neg-type new Γ obj pt)])]
                    [_