diff --git a/drracket-core-lib/drracket/private/colored-errors.rkt b/drracket-core-lib/drracket/private/colored-errors.rkt index 7f7778d2e..01ef1642e 100644 --- a/drracket-core-lib/drracket/private/colored-errors.rkt +++ b/drracket-core-lib/drracket/private/colored-errors.rkt @@ -47,15 +47,16 @@ ;; of additional source locations. These additional location will also be highlighted in the code, ;; even though they do not correspond to any section of the text of the error message. (struct colored-error-message (fragments additional-highlights) #:transparent) -(provide/contract [struct colored-error-message - ([fragments (listof msg-fragment?)] - [additional-highlights additional-highlights/c])] - [struct msg-fragment:str ([str string?])] - [struct msg-fragment:v ([v any/c])] - [struct colored-msg-fragment ([locs srcloc-syntax/c] - [frags (listof (or/c msg-fragment:str? msg-fragment:v?))] - [important boolean?] - [color color/c])]) +(provide (contract-out (struct colored-error-message + ([fragments (listof msg-fragment?)] [additional-highlights + additional-highlights/c])) + (struct msg-fragment:str ([str string?])) + (struct msg-fragment:v ([v any/c])) + (struct colored-msg-fragment + ([locs srcloc-syntax/c] + [frags (listof (or/c msg-fragment:str? msg-fragment:v?))] + [important boolean?] + [color color/c])))) ;; prop:exn:colored-message : The property of exceptions that contain colored-message information. ;; The property's value is a function that when given an exception, returns the colored-error-message. @@ -72,7 +73,7 @@ ;; get-error-message/color : When given an exception, if that exception contains coloring information, ;; returns it, otherwise, returns a colored-error-message that capture the information provided by ;; by field message and the srclocs property (if any) of the exception. -(provide/contract [get-error-message/color (exn? . -> . colored-error-message?)]) +(provide (contract-out [get-error-message/color (exn? . -> . colored-error-message?)])) (define (get-error-message/color exn) (cond [(exn:colored-message? exn) ((exn:colored-message-accessor exn) exn)] [(exn:srclocs? exn) @@ -81,11 +82,13 @@ [else (colored-error-message (list (msg-fragment:str (exn-message exn))) empty)])) -(provide/contract [get-error-colored-srclocs (exn? . -> . (listof (list/c srcloc-syntax/c color/c)))]) +(provide (contract-out [get-error-colored-srclocs + (exn? . -> . (listof (list/c srcloc-syntax/c color/c)))])) (define (get-error-colored-srclocs exn) (get-message-colored-srclocs (get-error-message/color exn))) -(provide/contract [get-message-colored-srclocs (colored-error-message? . -> . (listof (list/c srcloc-syntax/c color/c)))]) +(provide (contract-out [get-message-colored-srclocs + (colored-error-message? . -> . (listof (list/c srcloc-syntax/c color/c)))])) (define (get-message-colored-srclocs msg) (define (promote srcloc) (if (list? srcloc) srcloc (list srcloc #f))) (map promote @@ -165,12 +168,12 @@ (check-arg "~|" args 1) (define-values (sub rest-args) (let loop ([fragments fragments] [args (rest args)]) - (if (empty? fragments) - (values empty args) - (let () - (define-values (f rest-args) (colored-format:str-or-v (first fragments) args)) - (define-values (rest-fs rest-rest-args) (loop (rest fragments) rest-args)) - (values (cons f rest-fs) rest-rest-args))))) + (cond + [(empty? fragments) (values empty args)] + [else + (define-values (f rest-args) (colored-format:str-or-v (first fragments) args)) + (define-values (rest-fs rest-rest-args) (loop (rest fragments) rest-args)) + (values (cons f rest-fs) rest-rest-args)]))) (define the-arg (first args)) (match the-arg [(list loc imp col other ..1) @@ -190,7 +193,7 @@ (define colored-format/c (([fmt string?]) (#:additional-highlights [additional-highlights additional-highlights/c]) #:rest [_ any/c] . ->i . [_ colored-error-message?])) -(provide/contract [colored-format colored-format/c]) +(provide (contract-out [colored-format colored-format/c])) ;; colored-format : Takes a format string and a number of arguments, and produces a string where each ;; format marker has been replaced by their corresponding argument. This function support @@ -279,7 +282,7 @@ ;; The message and srcloc fields of the exception are populated from the information ;; in the fmt. additional-highlights specifies srclocs that should be highlighted, in addition ;; to the highlights used to explicate the correspondance between the text and the piece of codes. -(provide/contract [raise-colored-syntax-error colored-format/c]) +(provide (contract-out [raise-colored-syntax-error colored-format/c])) (define (raise-colored-syntax-error fmt #:additional-highlights [additional-highlights empty] . args) (define formatted (apply colored-format fmt #:additional-highlights additional-highlights args)) (raise (exn:fail:colored:syntax (uncolor-message formatted) diff --git a/drracket-core-lib/drracket/private/frame.rkt b/drracket-core-lib/drracket/private/frame.rkt index 418f94195..ef7bb09ea 100644 --- a/drracket-core-lib/drracket/private/frame.rkt +++ b/drracket-core-lib/drracket/private/frame.rkt @@ -262,47 +262,42 @@ (when (is-a? item menu-item-container<%>) (loop item)))) (when (member (system-type) '(unix windows)) - (for ([top-level-menu (in-list (send mb get-items))]) - (when (is-a? top-level-menu menu%) - (define amp-key - (let loop ([str (send top-level-menu get-label)]) - (cond - [(regexp-match #rx"[^&]*[&](.)(.*)" str) - => - (λ (m) - (define this-amp (list-ref m 1)) - (define rest (list-ref m 2)) - (cond - [(equal? this-amp "&") - (loop rest)] - [else - (string-downcase this-amp)]))] - [else #f]))) - (when amp-key - (hash-set! name-ht - (string->symbol (format "m:~a" amp-key)) - (format "~a menu" (send top-level-menu get-plain-label))) - (when (equal? (system-type) 'windows) - (hash-set! name-ht - (string->symbol (format "m:s:~a" amp-key)) - (format "~a menu" (send top-level-menu get-plain-label))))))))) + (for ([top-level-menu (in-list (send mb get-items))] + #:when (is-a? top-level-menu menu%)) + (define amp-key + (let loop ([str (send top-level-menu get-label)]) + (cond + [(regexp-match #rx"[^&]*[&](.)(.*)" str) + => + (λ (m) + (define this-amp (list-ref m 1)) + (define rest (list-ref m 2)) + (cond + [(equal? this-amp "&") (loop rest)] + [else (string-downcase this-amp)]))] + [else #f]))) + (when amp-key + (hash-set! name-ht + (string->symbol (format "m:~a" amp-key)) + (format "~a menu" (send top-level-menu get-plain-label))) + (when (equal? (system-type) 'windows) + (hash-set! name-ht + (string->symbol (format "m:s:~a" amp-key)) + (format "~a menu" (send top-level-menu get-plain-label)))))))) name-ht) (define (menu-item->prefix-string item) (apply string-append - (map (λ (prefix) - (case prefix - [(alt) (if (eq? (system-type) 'windows) - "m:" - "a:")] - [(cmd) "d:"] - [(meta) "m:"] - [(ctl) "c:"] - [(shift) "s:"] - [(opt option) "a:"] - [else (error 'menu-item->prefix-string "unknown prefix ~s\n" prefix)])) - (send item get-shortcut-prefix))))) + (for/list ([prefix (in-list (send item get-shortcut-prefix))]) + (case prefix + [(alt) (if (eq? (system-type) 'windows) "m:" "a:")] + [(cmd) "d:"] + [(meta) "m:"] + [(ctl) "c:"] + [(shift) "s:"] + [(opt option) "a:"] + [else (error 'menu-item->prefix-string "unknown prefix ~s\n" prefix)]))))) (require string-constants racket/match diff --git a/drracket-core-lib/drracket/private/insulated-read-language.rkt b/drracket-core-lib/drracket/private/insulated-read-language.rkt index 935bce4a7..e8778c509 100644 --- a/drracket-core-lib/drracket/private/insulated-read-language.rkt +++ b/drracket-core-lib/drracket/private/insulated-read-language.rkt @@ -266,8 +266,7 @@ Will not work with the definitions text surrogate interposition that (λ () (val text start-position limit-position direction)))))] [(drracket:keystrokes) (for/list ([pr (in-list val)]) - (define key (list-ref pr 0)) - (define proc (list-ref pr 1)) + (match-define (list key proc) pr) (list key (procedure-rename (λ (txt evt) (call-in-irl-context/abort @@ -440,9 +439,8 @@ Will not work with the definitions text surrogate interposition that [(and (equal? p1 #\|) (equal? (peek-char-or-special port 1) #\#)) (get-it "|#") - (cond - [(= depth 0) (void)] - [else (loop (- depth 1))])] + (unless (= depth 0) + (loop (- depth 1)))] [(and (equal? p1 #\#) (equal? (peek-char-or-special port 1) #\|)) (get-it "#|") @@ -479,9 +477,9 @@ Will not work with the definitions text surrogate interposition that (for ([chars (in-list (syntax->list #'(chars ...)))]) (unless (string? (syntax-e chars)) (raise-syntax-error 'chars "expected a string" stx chars)) - (for ([char (in-string (syntax-e chars))]) - (unless (< (char->integer char) 128) - (raise-syntax-error 'chars "expected only one-byte chars" stx chars)))) + (for ([char (in-string (syntax-e chars))] + #:unless (< (char->integer char) 128)) + (raise-syntax-error 'chars "expected only one-byte chars" stx chars))) #'(cond [(check-chars port chars) rhs ...] diff --git a/drracket-core-lib/drracket/private/palaka.rkt b/drracket-core-lib/drracket/private/palaka.rkt index 8399d52c3..61b97c684 100644 --- a/drracket-core-lib/drracket/private/palaka.rkt +++ b/drracket-core-lib/drracket/private/palaka.rkt @@ -24,17 +24,15 @@ (define (draw-palaka dc w h) (define alpha (send dc get-alpha)) (send dc set-pen palaka-color 1 'transparent) - (let loop ([dx (- (/ quadrant-size 2))]) - (when (< dx w) - (let loop ([dy (- (/ quadrant-size 2))]) - (when (< dy h) - (send dc set-alpha 1) - (send dc set-brush palaka-color 'solid) - (send dc draw-rectangle dx dy quadrant-size quadrant-size) - (send dc set-brush "white" 'solid) - (draw-one-palaka dc dx dy) - (loop (+ dy quadrant-size)))) - (loop (+ dx quadrant-size)))) + (for ([dx (in-range (- (/ quadrant-size 2)) w quadrant-size)]) + (let loop ([dy (- (/ quadrant-size 2))]) + (when (< dy h) + (send dc set-alpha 1) + (send dc set-brush palaka-color 'solid) + (send dc draw-rectangle dx dy quadrant-size quadrant-size) + (send dc set-brush "white" 'solid) + (draw-one-palaka dc dx dy) + (loop (+ dy quadrant-size))))) (send dc set-alpha alpha)) (define (draw-one-palaka dc dx dy) diff --git a/drracket-core-lib/drracket/private/stick-figures.rkt b/drracket-core-lib/drracket/private/stick-figures.rkt index af068f910..e500542dc 100644 --- a/drracket-core-lib/drracket/private/stick-figures.rkt +++ b/drracket-core-lib/drracket/private/stick-figures.rkt @@ -154,10 +154,8 @@ (define (normalize points) (define-values (min-x min-y) (get-max/min-x/y min points)) - (map (λ (x) (list (car x) - (- (list-ref x 1) min-x) - (- (list-ref x 2) min-y))) - points)) + (for/list ([x (in-list points)]) + (list (car x) (- (list-ref x 1) min-x) (- (list-ref x 2) min-y)))) (define (get-max/min-x/y choose points) (values (apply choose @@ -185,14 +183,14 @@ (send dc set-brush "black" 'transparent) (draw-points points dc factor dx dy) - (let* ([head (assoc 'head points)] - [hx (list-ref head 1)] - [hy (list-ref head 2)]) - (send dc draw-ellipse - (+ dx (* factor (- hx (/ head-size 2)))) - (+ dy (* factor (- hy (/ head-size 2)))) - (* factor head-size) - (* factor head-size))))) + (define head (assoc 'head points)) + (define hx (list-ref head 1)) + (define hy (list-ref head 2)) + (send dc draw-ellipse + (+ dx (* factor (- hx (/ head-size 2)))) + (+ dy (* factor (- hy (/ head-size 2)))) + (* factor head-size) + (* factor head-size)))) (define (draw-points points dc factor dx dy) (connect 'neck 'shoulders points dc factor dx dy) @@ -250,13 +248,12 @@ (set! orig-y (list-ref orig-point 2)))] [(and clicked-point (send evt moving?)) (set! points - (map (λ (x) - (if (eq? (car x) clicked-point) - (list (list-ref x 0) - (+ orig-x (- (send evt get-x) clicked-x)) - (+ orig-y (- (send evt get-y) clicked-y))) - x)) - points)) + (for/list ([x (in-list points)]) + (if (eq? (car x) clicked-point) + (list (list-ref x 0) + (+ orig-x (- (send evt get-x) clicked-x)) + (+ orig-y (- (send evt get-y) clicked-y))) + x))) (refresh) (send csmall refresh)] [(send evt button-up? 'left) diff --git a/drracket-core-lib/drracket/sprof.rkt b/drracket-core-lib/drracket/sprof.rkt index 6245bdfd0..bc665d140 100644 --- a/drracket-core-lib/drracket/sprof.rkt +++ b/drracket-core-lib/drracket/sprof.rkt @@ -16,9 +16,9 @@ (sleep pause-time) (define new-traces (map (λ (t) (continuation-mark-set->context (continuation-marks t))) (get-threads))) - (for ([trace (in-list new-traces)]) - (for ([line (in-list trace)]) - (hash-set! traces-table line (cons trace (hash-ref traces-table line '()))))) + (for* ([trace (in-list new-traces)] + [line (in-list trace)]) + (hash-set! traces-table line (cons trace (hash-ref traces-table line '())))) (cond [(zero? i) (update-gui traces-table) diff --git a/drracket-core-lib/scribble/tools/drracket-buttons.rkt b/drracket-core-lib/scribble/tools/drracket-buttons.rkt index 462d83f99..ead95d229 100644 --- a/drracket-core-lib/scribble/tools/drracket-buttons.rkt +++ b/drracket-core-lib/scribble/tools/drracket-buttons.rkt @@ -44,9 +44,9 @@ ;; if (eval 'doc) goes wrong, then we assume that's because of ;; an earlier failure, so we just don't do anything. (when doc - (printf "scribble: loading xref\n") + (displayln "scribble: loading xref") (define xref ((dynamic-require 'setup/xref 'load-collections-xref))) - (printf "scribble: rendering\n") + (displayln "scribble: rendering") (parameterize ([current-input-port (open-input-string "")]) ((dynamic-require 'scribble/render 'render) (list doc) diff --git a/drracket-tool-text-lib/drracket/find-module-path-completions.rkt b/drracket-tool-text-lib/drracket/find-module-path-completions.rkt index c715ac956..2c4741a0d 100644 --- a/drracket-tool-text-lib/drracket/find-module-path-completions.rkt +++ b/drracket-tool-text-lib/drracket/find-module-path-completions.rkt @@ -183,20 +183,20 @@ (and (regexp? (list-ref link-ent 2)) (regexp-match (list-ref link-ent 2) (version))) #t)) - `(,(list-ref link-ent 0) - ,(simplify-path - (let* ([encoded-path (list-ref link-ent 1)] - [path (cond - [(string? encoded-path) encoded-path] - [(bytes? encoded-path) (bytes->path encoded-path)] - [else (apply build-path - (for/list ([elem (in-list encoded-path)]) - (if (bytes? elem) - (bytes->path-element elem) - elem)))])]) - (if (relative-path? path) - (build-path base path) - path)))))] + (list (list-ref link-ent 0) + (simplify-path (let* ([encoded-path (list-ref link-ent 1)] + [path (cond + [(string? encoded-path) encoded-path] + [(bytes? encoded-path) (bytes->path encoded-path)] + [else + (apply build-path + (for/list ([elem (in-list encoded-path)]) + (if (bytes? elem) + (bytes->path-element elem) + elem)))])]) + (if (relative-path? path) + (build-path base path) + path)))))] [else '()])] [else (for/list ([clp (in-list library-collection-paths)])