diff --git a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt index afa318c27..8e313274e 100644 --- a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt @@ -224,11 +224,12 @@ (pattern (~seq (~optional (~seq (~and key (~or #:extra-constructor-name #:constructor-name)) name:id)) (~optional (~seq #:type-name type:id) #:defaults ([type struct-name]))) - #:attr ctor-value (if (attribute key) #'(key name) - (if legacy - #`(#:extra-constructor-name - #,(format-id struct-name "make-~a" struct-name)) - #'())))) + #:attr ctor-value (cond + [(attribute key) #'(key name)] + [legacy + #`(#:extra-constructor-name + #,(format-id struct-name "make-~a" struct-name))] + [else #'()]))) (define-syntax-class (struct-clause legacy) #:attributes (nm type (body 1) (constructor-parts 1) (tvar 1)) @@ -384,11 +385,14 @@ ;; will have added the casted expression's original type to the cast-table, so ;; that `(cast-table-ref id)` can get that type here. (λ () + (define types (cast-table-ref id)) (define type-stx - (let ([types (cast-table-ref id)]) - (cond [(not types) #f] - [(null? (cdr types)) (car types)] - [else (quasisyntax/loc (car types) (U #,@types))]))) + (cond + [(not types) #f] + [(null? (cdr types)) (car types)] + [else + (quasisyntax/loc (car types) + (U #,@types))])) `#s(contract-def ,type-stx ,flat? ,maker? typed ,te-mode)))) (define define-predicate @@ -653,17 +657,22 @@ (make-struct-info (lambda () - #,(if (syntax-e #'parent) - (let-values (((parent-type-des parent-maker parent-pred - parent-sel parent-mut grand-parent) - (apply values - (extract-struct-info/checked #'parent)))) - #`(struct-info-list - (list #,@(map maybe-add-quote-syntax parent-sel)) - (list #,@(map maybe-add-quote-syntax parent-mut)))) - #`(let-values (((new-sels new-muts) - (id-drop orig-sels orig-muts num-fields))) - (struct-info-list new-sels new-muts))))))) + #,(cond + [(syntax-e #'parent) + (define-values (parent-type-des + parent-maker + parent-pred + parent-sel + parent-mut + grand-parent) + (apply values (extract-struct-info/checked #'parent))) + #`(struct-info-list + (list #,@(map maybe-add-quote-syntax parent-sel)) + (list #,@(map maybe-add-quote-syntax parent-mut)))] + [else + #`(let-values ([(new-sels new-muts) + (id-drop orig-sels orig-muts num-fields)]) + (struct-info-list new-sels new-muts))]))))) (define-syntax nm (if id-is-ctor? diff --git a/typed-racket-lib/typed-racket/base-env/top-interaction.rkt b/typed-racket-lib/typed-racket/base-env/top-interaction.rkt index 5dbbf3830..7b87d7266 100644 --- a/typed-racket-lib/typed-racket/base-env/top-interaction.rkt +++ b/typed-racket-lib/typed-racket/base-env/top-interaction.rkt @@ -135,12 +135,9 @@ (λ (type) (match type [(tc-result1: (and t (? Fun?)) f o) - (let ([cleaned (cleanup-type t (parse-type #'desired-type) #f)]) - #`(display - #,(match cleaned - [(Fun: '()) - "Desired return type not in the given function's range.\n"] - [(Fun: _) - (pretty-format-rep cleaned)])))] + (define cleaned (cleanup-type t (parse-type #'desired-type) #f)) + #`(display #,(match cleaned + [(Fun: '()) "Desired return type not in the given function's range.\n"] + [(Fun: _) (pretty-format-rep cleaned)]))] [_ (error (format "~a: not a function" (syntax->datum #'op)))])) "must be applied to exactly two arguments")) diff --git a/typed-racket-lib/typed-racket/core.rkt b/typed-racket-lib/typed-racket/core.rkt index bd5ef1496..9e2369137 100644 --- a/typed-racket-lib/typed-racket/core.rkt +++ b/typed-racket-lib/typed-racket/core.rkt @@ -50,9 +50,7 @@ (with-refinements?)) (unless (eq? te-mode deep) (raise-arguments-error - (string->symbol (format "typed/racket/~a" - (keyword->string - (syntax-e te-attr)))) + (format-symbol "typed/racket/~a" te-attr) "#:with-refinements unsupported")))]) (tc-module/full te-mode stx pmb-form (λ (new-mod pre-before-code pre-after-code) diff --git a/typed-racket-lib/typed-racket/env/global-env.rkt b/typed-racket-lib/typed-racket/env/global-env.rkt index 6c026e7d5..059469d67 100644 --- a/typed-racket-lib/typed-racket/env/global-env.rkt +++ b/typed-racket-lib/typed-racket/env/global-env.rkt @@ -75,9 +75,7 @@ (define (maybe-finish-register-type id) (define v (free-id-table-ref the-mapping id)) - (if (box? v) - (register-type id (unbox v)) - #f)) + (and (box? v) (register-type id (unbox v)))) (define (unregister-type id) (free-id-table-remove! the-mapping id)) diff --git a/typed-racket-lib/typed-racket/env/init-envs.rkt b/typed-racket-lib/typed-racket/env/init-envs.rkt index 3cdecf0ba..4b0614fe1 100644 --- a/typed-racket-lib/typed-racket/env/init-envs.rkt +++ b/typed-racket-lib/typed-racket/env/init-envs.rkt @@ -437,10 +437,9 @@ (define (bound-in-this-module id) (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)) + (and (and (list? binding) (module-path-index? (car binding))) + (let-values ([(mp base) (module-path-index-split (car binding))]) + (not mp)))) (define (make-init-code map f) (define (bound-f id v) diff --git a/typed-racket-lib/typed-racket/env/type-env-structs.rkt b/typed-racket-lib/typed-racket/env/type-env-structs.rkt index e3b41ec51..944953e5b 100644 --- a/typed-racket-lib/typed-racket/env/type-env-structs.rkt +++ b/typed-racket-lib/typed-racket/env/type-env-structs.rkt @@ -97,27 +97,27 @@ (define (env-replace-props e props) - (match-let ([(env tys otys _ als) e]) - (env tys otys props als))) + (match-define (env tys otys _ als) e) + (env tys otys props als)) (define (env-lookup-id e key fail) - (match-let ([(env tys _ _ _) e]) - (free-id-table-ref tys key (λ () (fail key))))) + (match-define (env tys _ _ _) e) + (free-id-table-ref tys key (λ () (fail key)))) (define (env-lookup-obj e key fail) - (match-let ([(env _ otys _ _) e]) - (hash-ref otys key (λ () (fail key))))) + (match-define (env _ otys _ _) e) + (hash-ref otys key (λ () (fail key)))) ;; like hash-set, but for the type of an ident in the lexical environment (define (env-set-id-type e ident type) - (match-let ([(env tys otys ps als) e]) - (env (free-id-table-set tys ident type) otys ps als))) + (match-define (env tys otys ps als) e) + (env (free-id-table-set tys ident type) otys ps als)) ;; like hash-set, but for the type of an object in the lexical environment (define (env-set-obj-type e obj type) - (match-let ([(env tys otys ps als) e]) - (env tys (hash-set otys obj type) ps als))) + (match-define (env tys otys ps als) e) + (env tys (hash-set otys obj type) ps als)) ;; extends an environment with types and aliases ;; e : the 'env' struct to be updated @@ -157,6 +157,6 @@ (env tys otys ps als)) (define (env-lookup-alias e key fail) - (match-let ([(env _ _ _ als) e]) - (free-id-table-ref als key (λ () (fail key))))) + (match-define (env _ _ _ als) e) + (free-id-table-ref als key (λ () (fail key)))) diff --git a/typed-racket-lib/typed-racket/logic/ineq.rkt b/typed-racket-lib/typed-racket/logic/ineq.rkt index 6f5b8b644..1f00ac3bb 100644 --- a/typed-racket-lib/typed-racket/logic/ineq.rkt +++ b/typed-racket-lib/typed-racket/logic/ineq.rkt @@ -193,7 +193,7 @@ [(lexp: c ts) (define coeffs (terms-coeffs ts)) (if (zero? c) coeffs (cons c coeffs))] - [_ (error 'lexp-scalars "given invalid lexp ~a" exp)])) + [_ (raise-arguments-error 'lexp-scalars "given invalid lexp" "exp" exp)])) (module+ test (check-true (and (equal? (sort (lexp-vars (lexp* 17 '(42 x) '(2 z))) symbol (ax - bx) <= ...3 + ...4 - ...1 - ...2 [else (define lhs* (lexp 0 (make-terms x (- x-lhs-coeff x-rhs-coeff)))) - (define rhs* - (let ([rhs-c* (- rhs-c lhs-c)] - [rhs-h* (terms-subtract rhs-ts lhs-ts)]) - (lexp rhs-c* (terms-remove rhs-h* x)))) + (define rhs-c* (- rhs-c lhs-c)) + (define rhs-h* (terms-subtract rhs-ts lhs-ts)) + (define rhs* (lexp rhs-c* (terms-remove rhs-h* x))) (leq lhs* rhs*)])])) ; x lhs @@ -497,7 +496,7 @@ ;; leq1: lexp1 <= bx ;; leq2: cx <= lexp2 [(and (eqv? 0 a) (eqv? 0 d)) (leq (lexp-scale l1 c) (lexp-scale r2 b))] - [else (error 'leq-join "cannot join ~a and ~a by ~a" leq1 leq2 x)]))) + [else (raise-arguments-error 'leq-join "cannot join and by" "leq1" leq1 "leq2" leq2 "x" x)]))) (module+ test (check-equal? (leq-join (leq (lexp* '(2 x)) diff --git a/typed-racket-lib/typed-racket/typed-reader.rkt b/typed-racket-lib/typed-racket/typed-reader.rkt index a9f157bcc..97042f2b2 100644 --- a/typed-racket-lib/typed-racket/typed-reader.rkt +++ b/typed-racket-lib/typed-racket/typed-reader.rkt @@ -31,40 +31,39 @@ (define (parse port read-one src) (skip-whitespace port) (define name (read-one)) - (begin0 (begin - (skip-whitespace port) - (let ([next (read-one)]) - (case (syntax-e next) - ;; type annotation - [(:) - (skip-whitespace port) - (type-label-property name (syntax->datum (read-one)))] - [(::) - (skip-whitespace port) - (datum->syntax name `(ann ,name : ,(read-one)))] - [(@) - (let ([elems (let loop ([es '()]) - (skip-whitespace port) - (if (equal? #\} (peek-char port)) - (reverse es) - (loop (cons (read-one) es))))]) - (datum->syntax name `(inst ,name : ,@elems)))] - ;; arbitrary property annotation - [(PROP) + (skip-whitespace port) + (begin0 (let ([next (read-one)]) + (case (syntax-e next) + ;; type annotation + [(:) + (skip-whitespace port) + (type-label-property name (syntax->datum (read-one)))] + [(::) + (skip-whitespace port) + (datum->syntax name `(ann ,name : ,(read-one)))] + [(@) + (let ([elems (let loop ([es '()]) + (skip-whitespace port) + (if (equal? #\} (peek-char port)) + (reverse es) + (loop (cons (read-one) es))))]) + (datum->syntax name `(inst ,name : ,@elems)))] + ;; arbitrary property annotation + [(PROP) + (skip-whitespace port) + (let* ([prop-name (syntax-e (read-one))]) (skip-whitespace port) - (let* ([prop-name (syntax-e (read-one))]) - (skip-whitespace port) - (syntax-property name prop-name (read-one)))] - ;; otherwise error - [else - (let-values ([(l c p) (port-next-location port)]) - (raise-read-error (format "typed expression ~a must be followed by :, ::, or @" - (syntax->datum name)) - src - l - c - p - 1))]))) + (syntax-property name prop-name (read-one)))] + ;; otherwise error + [else + (define-values (l c p) (port-next-location port)) + (raise-read-error (format "typed expression ~a must be followed by :, ::, or @" + (syntax->datum name)) + src + l + c + p + 1)])) (skip-whitespace port) (let ([c (read-char port)]) (unless (equal? #\} c) diff --git a/typed-racket-test/succeed/shallow/pr241-variation-5.rkt b/typed-racket-test/succeed/shallow/pr241-variation-5.rkt index bcbd4741e..1b048a664 100644 --- a/typed-racket-test/succeed/shallow/pr241-variation-5.rkt +++ b/typed-racket-test/succeed/shallow/pr241-variation-5.rkt @@ -388,7 +388,8 @@ (filtered-in (if WARN-MISSING (lambda (str) - (when (not (known-string? str)) (printf "WARNING: Missing test for base type '~a'\n" str)) + (unless (known-string? str) + (printf "WARNING: Missing test for base type '~a'\n" str)) #f) (lambda (str) #f)) typed-racket/base-env/base-types)) diff --git a/typed-racket-test/succeed/shallow/untyped-struct-properties-with-self.rkt b/typed-racket-test/succeed/shallow/untyped-struct-properties-with-self.rkt index a53de7d5b..6eaf2e9eb 100644 --- a/typed-racket-test/succeed/shallow/untyped-struct-properties-with-self.rkt +++ b/typed-racket-test/succeed/shallow/untyped-struct-properties-with-self.rkt @@ -8,7 +8,7 @@ (module ty-foo typed/racket/shallow (require/typed (submod ".." foo) [prop:hi (Struct-Property (-> Self Any))] [hi-ref (-> Any (-> Any Void))]) (struct bar () #:property prop:hi (λ ([self : bar]) - (display (format "instance bar\n" )))) + (display "instance bar\n"))) (hi-ref (bar)) )