From cbfb1fdb370244c2cadcf327332f1c643d4588c0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 19 Oct 2012 06:47:24 -0400 Subject: [PATCH] A whole bunch of missing newlines at EOFs (and a few other spaceages). --- collects/2htdp/tests/struct-universe.rkt | 2 +- collects/compatibility/defmacro.rkt | 2 +- collects/future-visualizer/main.rkt | 20 +- .../future-visualizer/private/constants.rkt | 52 +- .../private/drawing-helpers.rkt | 139 ++- .../private/graph-drawing.rkt | 2 +- .../future-visualizer/private/gui-helpers.rkt | 45 +- .../private/visualizer-data.rkt | 2 +- .../private/visualizer-drawing.rkt | 976 +++++++++--------- collects/future-visualizer/trace.rkt | 24 +- collects/lang/private/sl-eval.rkt | 8 +- collects/mzlib/integer-set.rkt | 2 +- collects/mzlib/process.rkt | 2 +- collects/scribblings/scribble/renderer.scrbl | 2 +- .../examples/external-interface-example.rkt | 2 +- collects/tests/drracket/snip/run-all.rkt | 2 +- collects/tests/future/trace.rkt | 2 +- collects/tests/generic/empty-interface.rkt | 2 +- collects/tests/typed-racket/send-places.rkt | 2 +- .../typed-racket/succeed/poly-struct-pred.rkt | 2 +- collects/typed-racket/env/env-req.rkt | 2 +- collects/typed-racket/env/mvar-env.rkt | 2 +- .../typed-racket/utils/disappeared-use.rkt | 2 +- collects/unstable/open-place.rkt | 2 +- 24 files changed, 639 insertions(+), 659 deletions(-) diff --git a/collects/2htdp/tests/struct-universe.rkt b/collects/2htdp/tests/struct-universe.rkt index 4fae9ab918..a4e059cac0 100644 --- a/collects/2htdp/tests/struct-universe.rkt +++ b/collects/2htdp/tests/struct-universe.rkt @@ -50,4 +50,4 @@ (launch-many-worlds (client 'blue) (client 'red) (server))) -(require (submod "." run)) \ No newline at end of file +(require (submod "." run)) diff --git a/collects/compatibility/defmacro.rkt b/collects/compatibility/defmacro.rkt index 9a9594b0c2..ca92215b62 100644 --- a/collects/compatibility/defmacro.rkt +++ b/collects/compatibility/defmacro.rkt @@ -133,4 +133,4 @@ [else v]))))))) ;; this require has to be here after the submodule -(require (for-syntax 'dmhelp)) \ No newline at end of file +(require (for-syntax 'dmhelp)) diff --git a/collects/future-visualizer/main.rkt b/collects/future-visualizer/main.rkt index 1084a995a1..f4349721bb 100644 --- a/collects/future-visualizer/main.rkt +++ b/collects/future-visualizer/main.rkt @@ -33,21 +33,17 @@ (x y width height) (implies (or x y width height) (and x y width height)) - [p pict?])])) + [p pict?])])) -(define-syntax-rule (visualize-futures e ...) - (begin (start-future-tracing!) - (begin0 (begin e ...) - (stop-future-tracing!) - (show-visualizer)))) +(define-syntax-rule (visualize-futures e ...) + (begin (start-future-tracing!) + (begin0 (begin e ...) + (stop-future-tracing!) + (show-visualizer)))) ;;visualize-futures-thunk : (-> any/c) -> any/c (define (visualize-futures-thunk thunk) - (start-future-tracing!) - (begin0 - (thunk) + (start-future-tracing!) + (begin0 (thunk) (stop-future-tracing!) (show-visualizer))) - - - \ No newline at end of file diff --git a/collects/future-visualizer/private/constants.rkt b/collects/future-visualizer/private/constants.rkt index 6bd3a1ab68..7b796fc154 100644 --- a/collects/future-visualizer/private/constants.rkt +++ b/collects/future-visualizer/private/constants.rkt @@ -1,47 +1,47 @@ -#lang racket/base -(provide DEF-WINDOW-WIDTH - DEF-WINDOW-HEIGHT - RT-THREAD-ID - MIN-SEG-WIDTH - STROKE-WIDTH - MIN-SEG-INNER-WIDTH - DEFAULT-TIME-INTERVAL - TIMELINE-HEADER-OPACITY - CONNECTION-LINE-HAT-THRESHOLD - HAT-HEIGHT - CREATE-GRAPH-NODE-DIAMETER +#lang racket/base +(provide DEF-WINDOW-WIDTH + DEF-WINDOW-HEIGHT + RT-THREAD-ID + MIN-SEG-WIDTH + STROKE-WIDTH + MIN-SEG-INNER-WIDTH + DEFAULT-TIME-INTERVAL + TIMELINE-HEADER-OPACITY + CONNECTION-LINE-HAT-THRESHOLD + HAT-HEIGHT + CREATE-GRAPH-NODE-DIAMETER CREATE-GRAPH-PADDING - CREATE-GRAPH-MIN-ZOOM - CREATE-GRAPH-MAX-ZOOM - CREATE-GRAPH-DEFAULT-ZOOM + CREATE-GRAPH-MIN-ZOOM + CREATE-GRAPH-MAX-ZOOM + CREATE-GRAPH-DEFAULT-ZOOM CREATE-GRAPH-ZOOM-FACTOR - TIMELINE-ROW-HEIGHT + TIMELINE-ROW-HEIGHT TIMELINE-MIN-TICK-PADDING - HEADER-PADDING - DEFAULT-TIMELINE-WIDTH - HEADER-HEIGHT + HEADER-PADDING + DEFAULT-TIMELINE-WIDTH + HEADER-HEIGHT TOOLTIP-MARGIN) -(define DEF-WINDOW-WIDTH 1500) +(define DEF-WINDOW-WIDTH 1500) (define DEF-WINDOW-HEIGHT 1000) (define RT-THREAD-ID 0) (define MIN-SEG-WIDTH 10) (define STROKE-WIDTH 2) -(define MIN-SEG-INNER-WIDTH (- MIN-SEG-WIDTH STROKE-WIDTH)) +(define MIN-SEG-INNER-WIDTH (- MIN-SEG-WIDTH STROKE-WIDTH)) ;Default time interval (in MS) between ticks on the timeline (define DEFAULT-TIME-INTERVAL (/ 1 10)) (define TIMELINE-HEADER-OPACITY 0.6) -(define CONNECTION-LINE-HAT-THRESHOLD 20) +(define CONNECTION-LINE-HAT-THRESHOLD 20) (define HAT-HEIGHT 9) (define CREATE-GRAPH-NODE-DIAMETER 30) (define CREATE-GRAPH-PADDING 5) -(define CREATE-GRAPH-MIN-ZOOM 1) -(define CREATE-GRAPH-MAX-ZOOM 5) +(define CREATE-GRAPH-MIN-ZOOM 1) +(define CREATE-GRAPH-MAX-ZOOM 5) (define CREATE-GRAPH-DEFAULT-ZOOM 3) (define CREATE-GRAPH-ZOOM-FACTOR .4) (define TIMELINE-ROW-HEIGHT 100) (define TIMELINE-MIN-TICK-PADDING 10) (define HEADER-PADDING 5) (define DEFAULT-TIMELINE-WIDTH 1000) -(define HEADER-HEIGHT 30) -(define TOOLTIP-MARGIN 5) \ No newline at end of file +(define HEADER-HEIGHT 30) +(define TOOLTIP-MARGIN 5) diff --git a/collects/future-visualizer/private/drawing-helpers.rkt b/collects/future-visualizer/private/drawing-helpers.rkt index 1005705522..549b629c9c 100644 --- a/collects/future-visualizer/private/drawing-helpers.rkt +++ b/collects/future-visualizer/private/drawing-helpers.rkt @@ -1,109 +1,106 @@ -#lang racket/base -(require slideshow/pict +#lang racket/base +(require slideshow/pict "display.rkt" "constants.rkt") -(provide opacity-layer - circle-pict - rect-pict - text-pict - text-block-pict - draw-line-onto - make-stand-out - at +(provide opacity-layer + circle-pict + rect-pict + text-pict + text-block-pict + draw-line-onto + make-stand-out + at draw-stack-onto) ;;opacity-layer : float uint uint -> pict -(define (opacity-layer alpha w h) +(define (opacity-layer alpha w h) (cellophane (colorize (filled-rectangle w h) - "white") + "white") 0.6)) ;;circle-pict : string string uint [uint] -> pict -(define (circle-pict color stroke-color width #:stroke-width [stroke-width 1]) - (pin-over (colorize (filled-ellipse width - width) - stroke-color) - (* stroke-width 2) - (* stroke-width 2) - (colorize (filled-ellipse (- width (* stroke-width 4)) - (- width (* stroke-width 4))) +(define (circle-pict color stroke-color width #:stroke-width [stroke-width 1]) + (pin-over (colorize (filled-ellipse width width) + stroke-color) + (* stroke-width 2) + (* stroke-width 2) + (colorize (filled-ellipse (- width (* stroke-width 4)) + (- width (* stroke-width 4))) color))) ;;rect-pict : string string uint uint [uint] -> pict -(define (rect-pict color stroke-color width height #:stroke-width [stroke-width 1]) - (pin-over (colorize (filled-rectangle width height) - stroke-color) - (* stroke-width 2) - (* stroke-width 2) - (colorize (filled-rectangle (- width (* stroke-width 4)) - (- height (* stroke-width 4))) +(define (rect-pict color stroke-color width height #:stroke-width [stroke-width 1]) + (pin-over (colorize (filled-rectangle width height) + stroke-color) + (* stroke-width 2) + (* stroke-width 2) + (colorize (filled-rectangle (- width (* stroke-width 4)) + (- height (* stroke-width 4))) color))) ;;text-pict : string [string] -> pict -(define (text-pict t #:color [color "black"]) +(define (text-pict t #:color [color "black"]) (colorize (text t) color)) ;;text-block-pict : string [string] [string] [uint] [float] [uint] [uint] -> pict -(define (text-block-pict t #:backcolor [backcolor "white"] - #:forecolor [forecolor "black"] - #:padding [padding 10] - #:opacity [opacity 1.0] - #:width [width 0] +(define (text-block-pict t #:backcolor [backcolor "white"] + #:forecolor [forecolor "black"] + #:padding [padding 10] + #:opacity [opacity 1.0] + #:width [width 0] #:height [height 0]) (let* ([textp (colorize (text t) forecolor)] [padx2 (* padding 2)] - [text-cont (pin-over (blank (+ (pict-width textp) padx2) - (+ (pict-height textp) padx2)) - padding - padding + [text-cont (pin-over (blank (+ (pict-width textp) padx2) + (+ (pict-height textp) padx2)) + padding + padding textp)] - [bg (cellophane (colorize (filled-rectangle (max width (pict-width text-cont)) - (max height (pict-height text-cont))) - backcolor) - opacity)]) - (lc-superimpose bg text-cont))) + [bg (cellophane (colorize (filled-rectangle (max width (pict-width text-cont)) + (max height (pict-height text-cont))) + backcolor) + opacity)]) + (lc-superimpose bg text-cont))) ;;draw-line-onto : pict uint uint uint uint string -> pict -(define (draw-line-onto base - startx - starty - endx - endy +(define (draw-line-onto base + startx + starty + endx + endy color - #:width [width 1] - #:with-arrow [with-arrow #f] + #:width [width 1] + #:with-arrow [with-arrow #f] #:arrow-sz [arrow-sz 10] - #:style [style 'solid]) - (let ([dx (- endx startx)] - [dy (- endy starty)] + #:style [style 'solid]) + (let ([dx (- endx startx)] + [dy (- endy starty)] [line-f (if with-arrow pip-arrow-line pip-line)]) - (pin-over base - startx - starty - (linewidth width - (linestyle style - (colorize (line-f dx - dy - arrow-sz) + (pin-over base + startx + starty + (linewidth width + (linestyle style + (colorize (line-f dx dy arrow-sz) color)))))) ;;make-stand-out : pict -> pict -(define (make-stand-out pict) +(define (make-stand-out pict) (scale pict 2)) (struct draw-at (x y p) #:transparent) ;;at : uint uint pict -> draw-at -(define (at x y p) +(define (at x y p) (draw-at x y p)) ;;draw-stack-onto : pict (listof pict) -> pict -(define (draw-stack-onto base . picts) - (for/fold ([p base]) ([cur-p (in-list picts)]) - (cond - [(pict? cur-p) (pin-over p 0 0 cur-p)] - [(draw-at? cur-p) (pin-over p - (draw-at-x cur-p) - (draw-at-y cur-p) - (draw-at-p cur-p))] - [else (error 'draw-onto "Invalid argument in 'picts' list.")]))) \ No newline at end of file +(define (draw-stack-onto base . picts) + (for/fold ([p base]) ([cur-p (in-list picts)]) + (cond + [(pict? cur-p) (pin-over p 0 0 cur-p)] + [(draw-at? cur-p) (pin-over p + (draw-at-x cur-p) + (draw-at-y cur-p) + (draw-at-p cur-p))] + [else (error 'draw-onto "Invalid argument in 'picts' list.")]))) diff --git a/collects/future-visualizer/private/graph-drawing.rkt b/collects/future-visualizer/private/graph-drawing.rkt index a2d822b303..ee4f6963df 100644 --- a/collects/future-visualizer/private/graph-drawing.rkt +++ b/collects/future-visualizer/private/graph-drawing.rkt @@ -194,4 +194,4 @@ (error 'draw-tree "Invalid tree drawing style.")])]) (graph-layout (+ (graph-layout-width layout) scaled-padding) (+ (graph-layout-height layout) scaled-padding) - (graph-layout-nodes layout)))) \ No newline at end of file + (graph-layout-nodes layout)))) diff --git a/collects/future-visualizer/private/gui-helpers.rkt b/collects/future-visualizer/private/gui-helpers.rkt index 60af714779..cb27e617e1 100644 --- a/collects/future-visualizer/private/gui-helpers.rkt +++ b/collects/future-visualizer/private/gui-helpers.rkt @@ -15,15 +15,15 @@ post-event) (define bold-system-font - (send the-font-list find-or-create-font - (send normal-control-font get-point-size) - (send normal-control-font get-family) - (send normal-control-font get-style) + (send the-font-list find-or-create-font + (send normal-control-font get-point-size) + (send normal-control-font get-family) + (send normal-control-font get-style) 'bold)) -(define (label p str) - (new message% [parent p] - [label str] +(define (label p str) + (new message% [parent p] + [label str] [stretchable-width #t])) (define (mt-label p) @@ -77,30 +77,23 @@ c)) ;Events -;receiver : any +;receiver : any ;handler : (any -> void) (struct event-target (receiver handler) #:transparent) (define (make-listener-table) (make-hash)) -(define (add-receiver table evt-name object handler) - (hash-update! table - evt-name - (λ (old) - (cons (event-target object handler) old)) +(define (add-receiver table evt-name object handler) + (hash-update! table + evt-name + (λ (old) + (cons (event-target object handler) old)) (list (event-target object handler)))) -(define (post-event table name sender arg) - (let ([targets (hash-ref table name)]) - (for ([target (in-list targets)]) - (let ([receiver (event-target-receiver target)] - [handler (event-target-handler target)]) - (unless (eq? receiver sender) +(define (post-event table name sender arg) + (let ([targets (hash-ref table name)]) + (for ([target (in-list targets)]) + (let ([receiver (event-target-receiver target)] + [handler (event-target-handler target)]) + (unless (eq? receiver sender) (handler arg)))))) - - - - - - - \ No newline at end of file diff --git a/collects/future-visualizer/private/visualizer-data.rkt b/collects/future-visualizer/private/visualizer-data.rkt index 41677a8241..c7af31f6b2 100644 --- a/collects/future-visualizer/private/visualizer-data.rkt +++ b/collects/future-visualizer/private/visualizer-data.rkt @@ -526,4 +526,4 @@ (node root (build-creation-graph/private future-timelines root)))) (node 'runtime-thread - root-nodes)) \ No newline at end of file + root-nodes)) diff --git a/collects/future-visualizer/private/visualizer-drawing.rkt b/collects/future-visualizer/private/visualizer-drawing.rkt index d26b4134a8..d7d901a4a9 100644 --- a/collects/future-visualizer/private/visualizer-drawing.rkt +++ b/collects/future-visualizer/private/visualizer-drawing.rkt @@ -1,115 +1,115 @@ #lang racket/base -(require racket/list - racket/class +(require racket/list + racket/class racket/draw slideshow/pict data/interval-map - "visualizer-data.rkt" - "graph-drawing.rkt" + "visualizer-data.rkt" + "graph-drawing.rkt" "drawing-helpers.rkt" - "display.rkt" + "display.rkt" "constants.rkt") -(provide timeline-pict - timeline-pict-for-trace-data - timeline-overlay - seg-in-vregion - calc-segments +(provide timeline-pict + timeline-pict-for-trace-data + timeline-overlay + seg-in-vregion + calc-segments calc-ticks - calc-row-mid-y - find-seg-for-coords + calc-row-mid-y + find-seg-for-coords segment-edge segs-equal-or-later creation-tree-pict - draw-creategraph-pict + draw-creategraph-pict zoom-level->factor graph-overlay-pict - (struct-out segment) - (struct-out frame-info) - (struct-out timeline-tick) + (struct-out segment) + (struct-out frame-info) + (struct-out timeline-tick) find-node-for-coords find-fid-for-coords - first-seg-for-fid + first-seg-for-fid print-seg) ;Represents a dot or square on the timeline (struct segment (event - x - y - width - height - color + x + y + width + height + color opacity - p + p prev-future-seg - next-future-seg + next-future-seg prev-proc-seg - next-proc-seg + next-proc-seg prev-targ-future-seg next-targ-future-seg) #:transparent #:mutable) ;General information about the timeline image -(struct frame-info (adjusted-width +(struct frame-info (adjusted-width adjusted-height - row-height - modifier + row-height + modifier timeline-ticks process-line-coords) #:transparent) ;Represents a vertical line depicting a specific time in the execution history -(struct timeline-tick (x +(struct timeline-tick (x abs-time - rel-time - show-label?) #:transparent) + rel-time + show-label?) #:transparent) ;;viewable-region-from-frame : frame-info -> viewable-region -(define (viewable-region-from-frame finfo) - (viewable-region 0 - 0 - (frame-info-adjusted-width finfo) +(define (viewable-region-from-frame finfo) + (viewable-region 0 + 0 + (frame-info-adjusted-width finfo) (frame-info-adjusted-height finfo))) ;;print-seg : segment -> void -(define (print-seg seg) - (printf "(segment type:~a x:~a y:~a width:~a height:~a color:~a\n" - (event-type (segment-event seg)) - (segment-x seg) - (segment-y seg) - (segment-width seg) - (segment-height seg) +(define (print-seg seg) + (printf "(segment type:~a x:~a y:~a width:~a height:~a color:~a\n" + (event-type (segment-event seg)) + (segment-x seg) + (segment-y seg) + (segment-width seg) + (segment-height seg) (segment-color seg))) ;;seg-in-vregion : viewable-region segment -> bool (define (seg-in-vregion vregion) - (λ (seg) - (in-viewable-region vregion - (segment-x seg) - (segment-y seg) - (segment-width seg) + (λ (seg) + (in-viewable-region vregion + (segment-x seg) + (segment-y seg) + (segment-width seg) (segment-height seg)))) ;;calc-seg-x : event process-timeline trace uint float -> uint -(define (calc-seg-x evt tr modifier) - (floor (* (relative-time tr (event-start-time evt)) +(define (calc-seg-x evt tr modifier) + (floor (* (relative-time tr (event-start-time evt)) modifier))) ;;calc-seg-width : float event -> uint (define (calc-seg-width modifier evt) - (case (event-type evt) - [(start-work start-0-work) (max MIN-SEG-WIDTH (* modifier (- (event-end-time evt) - (event-start-time evt))))] + (case (event-type evt) + [(start-work start-0-work) (max MIN-SEG-WIDTH (* modifier (- (event-end-time evt) + (event-start-time evt))))] [else MIN-SEG-WIDTH])) ;Finds the segment for given x and y mouse coordinates ;;find-seg-for-coords : uint uint interval-map -> segment -(define (find-seg-for-coords x y index) - (let ([xmap (interval-map-ref index y #f)]) - (if xmap - (interval-map-ref xmap x #f) +(define (find-seg-for-coords x y index) + (let ([xmap (interval-map-ref index y #f)]) + (if xmap + (interval-map-ref xmap x #f) #f))) ;;find-fid-for-coords : uint uint (listof drawable-node) -> drawable-node -(define (find-node-for-coords x y nodes) +(define (find-node-for-coords x y nodes) (define node-l (filter (λ (n) (define n-x (drawable-node-x n)) (define n-y (drawable-node-y n)) @@ -119,19 +119,19 @@ (x . < . (+ n-x n-w)) (y . < . (+ n-y n-w)))) (remove-duplicates (flatten nodes)))) - (cond - [(empty? node-l) - #f] - [(= 1 (length node-l)) - (car node-l)] - [else + (cond + [(empty? node-l) + #f] + [(= 1 (length node-l)) + (car node-l)] + [else (error 'find-node-for-coords "Multiple nodes found for coords: ~s ~s, ~s" x y node-l)])) ;;find-fid-for-coords : x y ??(listof (listof nodes)) by depth?? viewable-region -> fid (define (find-fid-for-coords x y nodes vregion) - (define n (find-node-for-coords x y nodes)) - (if n - (event-user-data (node-data (drawable-node-node n))) + (define n (find-node-for-coords x y nodes)) + (if n + (event-user-data (node-data (drawable-node-node n))) #f)) ;;first-seg-for-fid : future-id (listof segments) -> segment @@ -143,44 +143,44 @@ < #:key (λ (s) (event-start-time (segment-event s)))))) ;;calc-adjusted-width : uint trace -> uint -(define (calc-adjusted-width w tr) - (define baseModifier (/ w (- (trace-end-time tr) (trace-start-time tr)))) - (define max-x-extent (for*/fold ([x 0]) ([tl (in-list (trace-proc-timelines tr))] - [evt (in-list (process-timeline-events tl))]) - (max (+ (calc-seg-x evt tr baseModifier) - (calc-seg-width baseModifier evt)) - x))) +(define (calc-adjusted-width w tr) + (define baseModifier (/ w (- (trace-end-time tr) (trace-start-time tr)))) + (define max-x-extent (for*/fold ([x 0]) ([tl (in-list (trace-proc-timelines tr))] + [evt (in-list (process-timeline-events tl))]) + (max (+ (calc-seg-x evt tr baseModifier) + (calc-seg-width baseModifier evt)) + x))) (- (- w (- max-x-extent w)) MIN-SEG-WIDTH)) ;;calc-row-mid-y : uint uint trace -> uint (define (calc-row-mid-y proc-index row-height tr) (define PADDING 2) - (floor (- (+ (* (if (> (trace-num-gcs tr) 0) - (- proc-index 1) + (floor (- (+ (* (if (> (trace-num-gcs tr) 0) + (- proc-index 1) proc-index) - row-height) - (/ row-height 2)) + row-height) + (/ row-height 2)) PADDING))) ;Gets the center of a circle with (xleft, ytop) as the top-left coordinate. ;;calc-center : uint uint uint -> (values uint uint) -(define (calc-center xleft ytop diameter) - (let ([rad (floor (/ diameter 2))]) - (values (+ xleft rad) +(define (calc-center xleft ytop diameter) + (let ([rad (floor (/ diameter 2))]) + (values (+ xleft rad) (+ ytop rad)))) ;;segs-equal-or-after : float (listof segment) -> (listof segment) (define (segs-equal-or-later real-time segs) - (let loop ([sgs segs]) - (cond - [(null? sgs) '()] - [(>= (event-start-time (segment-event (car sgs))) real-time) sgs] - [else (loop (cdr sgs))]))) + (let loop ([sgs segs]) + (cond + [(null? sgs) '()] + [(>= (event-start-time (segment-event (car sgs))) real-time) sgs] + [else (loop (cdr sgs))]))) ;;segment-edge : segment -> uint -(define (segment-edge seg) - (define evt (segment-event seg)) - (if (event-has-duration? evt) +(define (segment-edge seg) + (define evt (segment-event seg)) + (if (event-has-duration? evt) (segment-x seg) (+ (segment-x seg) (segment-width seg)))) @@ -195,24 +195,24 @@ (loop (cdr ss))]))) ;;timeline-tick-label-pict : real -> pict -(define (timeline-tick-label-pict rel-time) - (text-block-pict (format "~a ms" (real->decimal-string rel-time)) - #:backcolor (timeline-tick-label-backcolor) - #:forecolor (timeline-tick-label-forecolor) +(define (timeline-tick-label-pict rel-time) + (text-block-pict (format "~a ms" (real->decimal-string rel-time)) + #:backcolor (timeline-tick-label-backcolor) + #:forecolor (timeline-tick-label-forecolor) #:padding 3)) ;;calc-ticks : (listof segment) float trace -> (listof timeline-tick) (define (calc-ticks segs timeToPixMod tr) (define LABEL-PAD 3) (define trace-start (inexact->exact (trace-start-time tr))) - (define segs-len (length segs)) - (define-values (lt lx tks _ __) - (for/fold ([last-time trace-start] + (define segs-len (length segs)) + (define-values (lt lx tks _ __) + (for/fold ([last-time trace-start] [last-x 0] [ticks '()] [last-label-x-extent 0] - [remain-segs segs]) ([i (in-range 0 (floor (/ (- (trace-end-time tr) - trace-start) + [remain-segs segs]) ([i (in-range 0 (floor (/ (- (trace-end-time tr) + trace-start) DEFAULT-TIME-INTERVAL)))]) (define tick-rel-time (* (add1 i) DEFAULT-TIME-INTERVAL)) (define tick-time (+ trace-start tick-rel-time)) @@ -223,58 +223,58 @@ (define most-recent-time (inexact->exact (event-start-time most-recent-evt))) (define next-evt (segment-event next-seg)) (define next-evt-time (inexact->exact (event-start-time next-evt))) - (define most-recent-edge (segment-edge most-recent-seg)) + (define most-recent-edge (segment-edge most-recent-seg)) (define next-edge (segment-x next-seg)) - (define tick-x - (cond - [(= most-recent-time tick-time) (segment-x most-recent-seg)] - [(= (segment-x next-seg) (add1 (+ (segment-x most-recent-seg) (segment-width most-recent-seg)))) - (+ (segment-x most-recent-seg) (segment-width most-recent-seg))] - [else + (define tick-x + (cond + [(= most-recent-time tick-time) (segment-x most-recent-seg)] + [(= (segment-x next-seg) (add1 (+ (segment-x most-recent-seg) (segment-width most-recent-seg)))) + (+ (segment-x most-recent-seg) (segment-width most-recent-seg))] + [else (define start-x (max most-recent-edge last-x)) (define start-time (max most-recent-time last-time)) (define size-mod (/ (- next-edge start-x) (- next-evt-time start-time))) (define x-offset (ceiling (* (- tick-time start-time) size-mod))) (round (+ start-x x-offset))])) (define show-tick? ((- tick-x last-x) . >= . TIMELINE-MIN-TICK-PADDING)) - (define show-label? - (if (not show-tick?) - #f + (define show-label? + (if (not show-tick?) + #f (>= tick-x (+ last-label-x-extent LABEL-PAD)))) - (define new-label-x-extent - (if show-label? + (define new-label-x-extent + (if show-label? (+ tick-x (pict-width (timeline-tick-label-pict tick-rel-time))) last-label-x-extent)) - (if show-tick? - (values tick-time - tick-x - (cons (timeline-tick tick-x tick-time tick-rel-time show-label?) ticks) - new-label-x-extent - r-segs) - (values tick-time - last-x - ticks - new-label-x-extent + (if show-tick? + (values tick-time + tick-x + (cons (timeline-tick tick-x tick-time tick-rel-time show-label?) ticks) + new-label-x-extent + r-segs) + (values tick-time + last-x + ticks + new-label-x-extent r-segs)))) - tks) + tks) ;;calc-process-timespan-lines : trace (listof segment) uint -> (listof (uint . uint)) (define (calc-process-timespan-lines trace segs max-x) - (for/list ([tl (in-list (trace-proc-timelines trace))]) - (define sgs (filter (λ (s) (equal? (process-timeline-proc-id tl) - (event-proc-id (segment-event s)))) - segs)) - (cond + (for/list ([tl (in-list (trace-proc-timelines trace))]) + (define sgs (filter (λ (s) (equal? (process-timeline-proc-id tl) + (event-proc-id (segment-event s)))) + segs)) + (cond [(empty? sgs) (cons 0 max-x)] [else - (cons (segment-x (car sgs)) + (cons (segment-x (car sgs)) (segment-x (last sgs)))]))) ;;get-first-future-seg : seg -> seg -(define (get-first-future-seg seg) - (let loop ([cur seg]) - (if (segment-prev-future-seg cur) - (loop (segment-prev-future-seg cur)) +(define (get-first-future-seg seg) + (let loop ([cur seg]) + (if (segment-prev-future-seg cur) + (loop (segment-prev-future-seg cur)) cur))) ;;get-first-future-seg-in-region : viewable-region segment -> segment @@ -286,63 +286,54 @@ ;; get-seg-previous-to-vregion : viewable-region segment -> segment (define (get-seg-previous-to-vregion vregion seg) - (let loop ([cur seg]) - (define prev (segment-prev-future-seg cur)) - (cond - [(or (not prev) (not ((seg-in-vregion vregion) cur))) cur] + (let loop ([cur seg]) + (define prev (segment-prev-future-seg cur)) + (cond + [(or (not prev) (not ((seg-in-vregion vregion) cur))) cur] [else (loop prev)]))) -;;Set pixel widths of segments with variable widths, e.g. +;;Set pixel widths of segments with variable widths, e.g. ;;work and GC events ;;adjust-variable-width-segs! : (listof segment) uint -> void -(define (adjust-variable-width-segs! segs max-x) - (cond +(define (adjust-variable-width-segs! segs max-x) + (cond [(empty? segs) void] - [else - (define cur (car segs)) - (case (event-type (segment-event cur)) - [(start-work start-0-work) + [else + (define cur (car segs)) + (case (event-type (segment-event cur)) + [(start-work start-0-work) (define next-seg (segment-next-proc-seg cur)) - ;Because we are truncating logs after they reach a certain size, - ;next-seg could be #f (where before it was safe to assume that a work segment + ;Because we are truncating logs after they reach a certain size, + ;next-seg could be #f (where before it was safe to assume that a work segment ;was always followed by another segment). - (define x-end (if next-seg - (segment-x next-seg) + (define x-end (if next-seg + (segment-x next-seg) max-x)) - (set-segment-width! cur (max MIN-SEG-WIDTH - (- x-end (segment-x cur)))) + (set-segment-width! cur (max MIN-SEG-WIDTH + (- x-end (segment-x cur)))) (adjust-variable-width-segs! (cdr segs) max-x)] - [(gc) - (cond - [(empty? (cdr segs)) void] - [else - (set-segment-width! cur (max MIN-SEG-WIDTH - (- (segment-x (car (cdr segs))) (segment-x cur)))) - (adjust-variable-width-segs! (cdr segs) max-x)])] + [(gc) + (cond + [(empty? (cdr segs)) void] + [else + (set-segment-width! cur (max MIN-SEG-WIDTH + (- (segment-x (car (cdr segs))) (segment-x cur)))) + (adjust-variable-width-segs! (cdr segs) max-x)])] [else (adjust-variable-width-segs! (cdr segs) max-x)])])) ;;connect-segments! : (listof segment) -> void -(define (connect-segments! segs) - (for ([s (in-list segs)]) - (let ([evt (segment-event s)]) - (set-segment-prev-proc-seg! s (if (event-prev-proc-event evt) - (event-segment (event-prev-proc-event evt)) - #f)) - (set-segment-next-proc-seg! s (if (event-next-proc-event evt) - (event-segment (event-next-proc-event evt)) - #f)) - (set-segment-prev-future-seg! s (if (event-prev-future-event evt) - (event-segment (event-prev-future-event evt)) - #f)) - (set-segment-next-future-seg! s (if (event-next-future-event evt) - (event-segment (event-next-future-event evt)) - #f)) - (set-segment-prev-targ-future-seg! s (if (event-prev-targ-future-event evt) - (event-segment (event-prev-targ-future-event evt)) - #f)) - (set-segment-next-targ-future-seg! s (if (event-next-targ-future-event evt) - (event-segment (event-next-targ-future-event evt)) - #f))))) +(define (connect-segments! segs) + (for ([s (in-list segs)]) + (define evt (segment-event s)) + (define (segment-of-evt getter) + (define x (getter evt)) + (and x (event-segment x))) + (set-segment-prev-proc-seg! s (segment-of-evt event-prev-proc-event)) + (set-segment-next-proc-seg! s (segment-of-evt event-next-proc-event)) + (set-segment-prev-future-seg! s (segment-of-evt event-prev-future-event)) + (set-segment-next-future-seg! s (segment-of-evt event-next-future-event)) + (set-segment-prev-targ-future-seg! s (segment-of-evt event-prev-targ-future-event)) + (set-segment-next-targ-future-seg! s (segment-of-evt event-next-targ-future-event)))) ;;build-seg-layout : flonum (listof event) trace -> (values (listof segment) uint uint) (define (build-seg-layout timeToPixModifier events tr max-y) @@ -353,36 +344,36 @@ [delta 0] [largest-x 0]) ([evt (in-list events)]) (define is-gc-evt? (equal? (event-type evt) 'gc)) - (define last-right-edge (if is-gc-evt? - largest-x + (define last-right-edge (if is-gc-evt? + largest-x (vector-ref last-right-edges (event-proc-index evt)))) (define wanted-offset (+ delta (* DEFAULT-TIMELINE-WIDTH - (inexact->exact + (inexact->exact (/ (- (event-start-time evt) (trace-start-time tr)) (- (trace-end-time tr) (trace-start-time tr))))))) - (define-values (offset new-delta) - (if (last-right-edge . <= . wanted-offset) + (define-values (offset new-delta) + (if (last-right-edge . <= . wanted-offset) (values wanted-offset delta) (values last-right-edge (+ delta (- last-right-edge wanted-offset))))) (define radius (if is-gc-evt? 0 (/ MIN-SEG-WIDTH 2))) (define segw MIN-SEG-WIDTH) - (define segh (cond - [is-gc-evt? max-y] + (define segh (cond + [is-gc-evt? max-y] [else MIN-SEG-WIDTH])) - (define seg (segment evt - (round offset) + (define seg (segment evt + (round offset) (- (calc-row-mid-y (event-proc-index evt) TIMELINE-ROW-HEIGHT tr) radius) segw - segh - (get-event-color (event-type evt)) + segh + (get-event-color (event-type evt)) (get-event-opacity (event-type evt)) - #f - #f - #f - #f - #f - #f - #f)) + #f + #f + #f + #f + #f + #f + #f)) (set-event-segment! evt seg) (vector-set! last-right-edges (event-proc-index evt) (+ offset segw)) (values (cons seg segs) @@ -391,483 +382,482 @@ (values sgs x-extent)) ;;calc-segments : trace uint uint -> (values frame-info (listof segment)) -(define (calc-segments tr) +(define (calc-segments tr) (define evts (trace-all-events tr)) (define timeToPixModifier (/ DEFAULT-TIMELINE-WIDTH (- (trace-end-time tr) (trace-start-time tr)))) (define max-y (* TIMELINE-ROW-HEIGHT (length (trace-proc-timelines tr)))) - (define-values (segments x) + (define-values (segments x) (build-seg-layout timeToPixModifier evts tr max-y)) (define max-x (+ MIN-SEG-WIDTH (round x))) (define ordered-segs (reverse segments)) (connect-segments! ordered-segs) (adjust-variable-width-segs! ordered-segs max-x) (define ticks (calc-ticks ordered-segs timeToPixModifier tr)) - (values (frame-info max-x + (values (frame-info max-x max-y - TIMELINE-ROW-HEIGHT - timeToPixModifier + TIMELINE-ROW-HEIGHT + timeToPixModifier ticks - (calc-process-timespan-lines tr ordered-segs max-x)) + (calc-process-timespan-lines tr ordered-segs max-x)) ordered-segs)) ;;pict-for-segment : segment -> pict -(define (pict-for-segment seg) +(define (pict-for-segment seg) (unless (segment-p seg) - (define p (if (event-has-duration? (segment-event seg)) + (define p (if (event-has-duration? (segment-event seg)) (rect-pict (segment-color seg) - (timeline-event-strokecolor) - (segment-width seg) - (segment-height seg) - #:stroke-width .5) - (circle-pict (segment-color seg) - (timeline-event-strokecolor) - MIN-SEG-WIDTH - #:stroke-width .5))) - (set-segment-p! seg (if (< (segment-opacity seg) 1) - (cellophane p (segment-opacity seg)) - p))) + (timeline-event-strokecolor) + (segment-width seg) + (segment-height seg) + #:stroke-width .5) + (circle-pict (segment-color seg) + (timeline-event-strokecolor) + MIN-SEG-WIDTH + #:stroke-width .5))) + (set-segment-p! seg (if (< (segment-opacity seg) 1) + (cellophane p (segment-opacity seg)) + p))) (segment-p seg)) ;;draw-ruler-on : pict viewable-region frameinfo -> pict (define (draw-ruler-on base vregion frameinfo) - (for/fold ([pct base]) ([tick (in-list (filter (λ (t) (in-viewable-region-horiz vregion (timeline-tick-x t))) + (for/fold ([pct base]) ([tick (in-list (filter (λ (t) (in-viewable-region-horiz vregion (timeline-tick-x t))) (frame-info-timeline-ticks frameinfo)))]) (define cur-x (timeline-tick-x tick)) - (define pinnedline - (pin-over pct - (- cur-x (viewable-region-x vregion)) - 0 - (linestyle 'dot - (colorize (vline 1 - (viewable-region-height vregion)) + (define pinnedline + (pin-over pct + (- cur-x (viewable-region-x vregion)) + 0 + (linestyle 'dot + (colorize (vline 1 + (viewable-region-height vregion)) (timeline-tick-color))))) (if (timeline-tick-show-label? tick) - (pin-over pinnedline - (- cur-x (viewable-region-x vregion)) - 3 + (pin-over pinnedline + (- cur-x (viewable-region-x vregion)) + 3 (timeline-tick-label-pict (timeline-tick-rel-time tick))) pinnedline))) ;;draw-row-lines-on : pict viewable-region trace frameinfo -> pict -(define (draw-row-lines-on base vregion tr finfo opacity) +(define (draw-row-lines-on base vregion tr finfo opacity) (define num-tls (length (trace-proc-timelines tr))) - (pin-over base - 0 + (pin-over base 0 - (for/fold ([pct base]) ([tl (in-list (filter (λ (tline) + 0 + (for/fold ([pct base]) ([tl (in-list (filter (λ (tline) (define midy (calc-row-mid-y (process-timeline-proc-index tline) - (frame-info-row-height finfo) + (frame-info-row-height finfo) tr)) - (define topy (- midy (frame-info-row-height finfo))) - (define boty (+ midy (frame-info-row-height finfo))) - (or (in-viewable-region-vert? vregion topy) - (in-viewable-region-vert? vregion boty))) + (define topy (- midy (frame-info-row-height finfo))) + (define boty (+ midy (frame-info-row-height finfo))) + (or (in-viewable-region-vert? vregion topy) + (in-viewable-region-vert? vregion boty))) (trace-proc-timelines tr)))]) - (let* ([line-coords (list-ref (frame-info-process-line-coords finfo) + (let* ([line-coords (list-ref (frame-info-process-line-coords finfo) (process-timeline-proc-index tl))] - [line-start (car line-coords)] + [line-start (car line-coords)] [line-end (cdr line-coords)] - [vregion-start (viewable-region-x vregion)] + [vregion-start (viewable-region-x vregion)] [vregion-end (viewable-region-x-extent vregion)] - [start-x (cond - [(< line-start vregion-start) 0] - [(between line-start vregion-start vregion-end) - (- line-start vregion-start)] + [start-x (cond + [(< line-start vregion-start) 0] + [(between line-start vregion-start vregion-end) + (- line-start vregion-start)] [else vregion-end])] - [end-x (cond - [(< line-end vregion-start) 0] - [(between line-end vregion-start vregion-end) - (- line-end vregion-start)] + [end-x (cond + [(< line-end vregion-start) 0] + [(between line-end vregion-start vregion-end) + (- line-end vregion-start)] [else vregion-end])] [index (process-timeline-proc-index tl)] - [proc-name (if (zero? index) - "Thread 0 (Runtime Thread)" + [proc-name (if (zero? index) + "Thread 0 (Runtime Thread)" (format "Thread ~a" (process-timeline-proc-id tl)))] - [proc-title (text-block-pict proc-name - #:backcolor (header-backcolor) - #:forecolor (header-forecolor) + [proc-title (text-block-pict proc-name + #:backcolor (header-backcolor) + #:forecolor (header-forecolor) #:padding HEADER-PADDING - #:opacity opacity + #:opacity opacity #:width (viewable-region-width vregion))]) - (draw-stack-onto pct - (at 0 - (- (* index (frame-info-row-height finfo)) (viewable-region-y vregion)) - (colorize (hline (viewable-region-width vregion) 1) (timeline-baseline-color))) - (at 0 - (+ (+ (- (* index (frame-info-row-height finfo)) (viewable-region-y vregion)) - (- (frame-info-row-height finfo) (pict-height proc-title))) - 1) - proc-title) - (at start-x - (- (calc-row-mid-y index - (frame-info-row-height finfo) + (draw-stack-onto pct + (at 0 + (- (* index (frame-info-row-height finfo)) (viewable-region-y vregion)) + (colorize (hline (viewable-region-width vregion) 1) (timeline-baseline-color))) + (at 0 + (+ (+ (- (* index (frame-info-row-height finfo)) (viewable-region-y vregion)) + (- (frame-info-row-height finfo) (pict-height proc-title))) + 1) + proc-title) + (at start-x + (- (calc-row-mid-y index + (frame-info-row-height finfo) tr) (viewable-region-y vregion)) - (colorize (hline (- end-x start-x) 1) + (colorize (hline (- end-x start-x) 1) (timeline-event-baseline-color)))))))) -;Magnifies a segment's pict (dot or square) to make +;Magnifies a segment's pict (dot or square) to make ;it stand out when hovered over with the mouse pointer. ;;make-stand-out-pict : segment -> pict -(define (make-stand-out-pict seg) - (case (event-type (segment-event seg)) - [(start-work start-0-work) (scale (pict-for-segment seg) 1 2)] +(define (make-stand-out-pict seg) + (case (event-type (segment-event seg)) + [(start-work start-0-work) (scale (pict-for-segment seg) 1 2)] [(gc) (cellophane (pict-for-segment seg) 1)] [else (scale (pict-for-segment seg) 2)])) ;;frame-bg : viewable-region frame-info trace -> pict (define (frame-bg vregion finfo tr) - (draw-frame-bg-onto (colorize (filled-rectangle (viewable-region-width vregion) - (frame-info-adjusted-height finfo)) + (draw-frame-bg-onto (colorize (filled-rectangle (viewable-region-width vregion) + (frame-info-adjusted-height finfo)) (timeline-frame-bg-color)) - vregion - finfo - tr + vregion + finfo + tr TIMELINE-HEADER-OPACITY)) ;;draw-frame-bg-onto : pict viewable-region frameinfo trace -> pict -(define (draw-frame-bg-onto base vregion finfo tr opacity) +(define (draw-frame-bg-onto base vregion finfo tr opacity) (let ([with-ruler (draw-ruler-on base vregion finfo)]) (draw-row-lines-on with-ruler vregion tr finfo opacity))) ;;timeline-pict : (listof indexed-future-event) [viewable-region] [integer] -> pict -(define (timeline-pict logs +(define (timeline-pict logs #:x [x #f] #:y [y #f] - #:width [width #f] + #:width [width #f] #:height [height #f] - #:selected-event-index [selected-event-index #f]) + #:selected-event-index [selected-event-index #f]) (define tr (build-trace logs)) (define-values (finfo segments) (calc-segments tr)) - (define vregion (if x - (viewable-region x y width height) + (define vregion (if x + (viewable-region x y width height) (viewable-region 0 0 (frame-info-adjusted-width finfo) (frame-info-adjusted-height finfo)))) - (timeline-pict-for-trace-data vregion - tr - finfo - segments + (timeline-pict-for-trace-data vregion + tr + finfo + segments #:selected-event-index selected-event-index)) ;;timeline-pict : (or viewable-region #f) trace frame-info (listof segment) -> pict -(define (timeline-pict-for-trace-data vregion - tr - finfo - segments - #:selected-event-index [selected-event-index #f]) - (define vr (if (not vregion) - (viewable-region 0 - 0 - (frame-info-adjusted-width finfo) - (frame-info-adjusted-height finfo)) +(define (timeline-pict-for-trace-data vregion + tr + finfo + segments + #:selected-event-index [selected-event-index #f]) + (define vr (if (not vregion) + (viewable-region 0 + 0 + (frame-info-adjusted-width finfo) + (frame-info-adjusted-height finfo)) vregion)) - (define tp (for/fold ([pct (frame-bg vr finfo tr)]) - ([seg (in-list (filter (seg-in-vregion vr) segments))]) + (define tp (for/fold ([pct (frame-bg vr finfo tr)]) + ([seg (in-list (filter (seg-in-vregion vr) segments))]) (pin-over pct - (- (segment-x seg) (viewable-region-x vr)) - (- (segment-y seg) (viewable-region-y vr)) - (pict-for-segment seg)))) - (cond - [selected-event-index + (- (segment-x seg) (viewable-region-x vr)) + (- (segment-y seg) (viewable-region-y vr)) + (pict-for-segment seg)))) + (cond + [selected-event-index (define overlay (timeline-overlay vregion - #f - (list-ref segments selected-event-index) - finfo - tr)) - (pin-over tp - 0 - 0 - overlay)] + #f + (list-ref segments selected-event-index) + finfo + tr)) + (pin-over tp + 0 + 0 + overlay)] [else tp])) ;;draw-connection : viewable-region segment segment pict string [uint bool symbol] -> pict -(define (draw-connection vregion - start - end - base-pct - color - #:width [width 1] - #:with-arrow [with-arrow #f] - #:style [style 'solid]) - (let*-values ([(midx midy) (calc-center (- (segment-x start) (viewable-region-x vregion)) - (- (segment-y start) (viewable-region-y vregion)) - MIN-SEG-WIDTH)] - [(nextx nexty) (calc-center (- (segment-x end) (viewable-region-x vregion)) - (- (segment-y end) (viewable-region-y vregion)) - MIN-SEG-WIDTH)] - [(dx dy) (values (- nextx midx) (- nexty midy))]) - (if (and (zero? dy) - (or (not (eq? (segment-next-proc-seg start) end)) - (< dx CONNECTION-LINE-HAT-THRESHOLD))) - (let* ([dxa (/ dx 2)] - [dya (- HAT-HEIGHT CONNECTION-LINE-HAT-THRESHOLD)] - [breakx (+ midx dxa)] +(define (draw-connection vregion + start + end + base-pct + color + #:width [width 1] + #:with-arrow [with-arrow #f] + #:style [style 'solid]) + (let*-values ([(midx midy) (calc-center (- (segment-x start) (viewable-region-x vregion)) + (- (segment-y start) (viewable-region-y vregion)) + MIN-SEG-WIDTH)] + [(nextx nexty) (calc-center (- (segment-x end) (viewable-region-x vregion)) + (- (segment-y end) (viewable-region-y vregion)) + MIN-SEG-WIDTH)] + [(dx dy) (values (- nextx midx) (- nexty midy))]) + (if (and (zero? dy) + (or (not (eq? (segment-next-proc-seg start) end)) + (< dx CONNECTION-LINE-HAT-THRESHOLD))) + (let* ([dxa (/ dx 2)] + [dya (- HAT-HEIGHT CONNECTION-LINE-HAT-THRESHOLD)] + [breakx (+ midx dxa)] [breaky (+ midy dya)]) - (draw-line-onto (draw-line-onto base-pct - midx - midy - breakx - breaky - color + (draw-line-onto (draw-line-onto base-pct + midx + midy + breakx + breaky + color #:width width - #:style style) - breakx - breaky - nextx - nexty - color - #:width width - #:with-arrow with-arrow + #:style style) + breakx + breaky + nextx + nexty + color + #:width width + #:with-arrow with-arrow #:style style)) - (draw-line-onto base-pct - midx - midy - nextx - nexty - color - #:width width - #:with-arrow with-arrow - #:style style)))) + (draw-line-onto base-pct + midx + midy + nextx + nexty + color + #:width width + #:with-arrow with-arrow + #:style style)))) ;;draw-arrows : pict viewable-region segment -> pict -(define (draw-arrows base-pct vregion seg) +(define (draw-arrows base-pct vregion seg) (let ([fst (get-seg-previous-to-vregion vregion seg)]) - (let loop ([pct base-pct] + (let loop ([pct base-pct] [cur-seg fst]) (if (not cur-seg) - pct + pct (let ([next (segment-next-future-seg cur-seg)]) - (let* ([next-targ (segment-next-targ-future-seg cur-seg)] - [prev-targ (segment-prev-targ-future-seg cur-seg)] - [ftl-arrows (if (not next) - pct - (draw-connection vregion - cur-seg - next - pct - (event-connection-line-color) - #:width 2))] - [prev-targ-arr (if (not prev-targ) - ftl-arrows - (draw-connection vregion - prev-targ - cur-seg - ftl-arrows - (event-target-future-line-color) - #:with-arrow #t - #:style 'dot))] - [next-targ-arr (if (not next-targ) - prev-targ-arr - (draw-connection vregion - cur-seg - next-targ - prev-targ-arr - (event-target-future-line-color) - #:with-arrow #t + (let* ([next-targ (segment-next-targ-future-seg cur-seg)] + [prev-targ (segment-prev-targ-future-seg cur-seg)] + [ftl-arrows (if (not next) + pct + (draw-connection vregion + cur-seg + next + pct + (event-connection-line-color) + #:width 2))] + [prev-targ-arr (if (not prev-targ) + ftl-arrows + (draw-connection vregion + prev-targ + cur-seg + ftl-arrows + (event-target-future-line-color) + #:with-arrow #t + #:style 'dot))] + [next-targ-arr (if (not next-targ) + prev-targ-arr + (draw-connection vregion + cur-seg + next-targ + prev-targ-arr + (event-target-future-line-color) + #:with-arrow #t #:style 'dot))]) - (if (and next + (if (and next ((seg-in-vregion vregion) next)) (loop next-targ-arr next) next-targ-arr))))))) -;Draws the pict that is layered on top of the exec. timeline canvas +;Draws the pict that is layered on top of the exec. timeline canvas ;to highlight a specific future's event sequence ;;timeline-overlay : uint uint (or segment #f) (or segment #f) frame-info trace -> pict (define (timeline-overlay vregion tacked hovered finfo tr) - (define-values (width height) (values (viewable-region-width vregion) + (define-values (width height) (values (viewable-region-width vregion) (viewable-region-height vregion))) - (define base (blank (viewable-region-width vregion) - (viewable-region-height vregion))) - (define-values (picked-seg showing-tacked) + (define base (blank (viewable-region-width vregion) + (viewable-region-height vregion))) + (define-values (picked-seg showing-tacked) (if tacked (values tacked #t) (values hovered #f))) - (cond - [picked-seg - (define bg base) - (define aseg-rel-x (- (segment-x picked-seg) (viewable-region-x vregion))) - (define aseg-rel-y (- (segment-y picked-seg) (viewable-region-y vregion))) + (cond + [picked-seg + (define bg base) + (define aseg-rel-x (- (segment-x picked-seg) (viewable-region-x vregion))) + (define aseg-rel-y (- (segment-y picked-seg) (viewable-region-y vregion))) (define emphasized (make-stand-out-pict picked-seg)) - (case (event-type (segment-event picked-seg)) - [(gc) + (case (event-type (segment-event picked-seg)) + [(gc) (pin-over bg aseg-rel-x aseg-rel-y emphasized)] - [else + [else (let* ([line (pin-over bg - (- (+ aseg-rel-x - (/ (segment-width picked-seg) 2)) + (- (+ aseg-rel-x + (/ (segment-width picked-seg) 2)) 2) 0 (colorize (vline 1 height) (hover-tickline-color)))] [width-dif (/ (- (pict-width emphasized) (segment-width picked-seg)) 2)] [height-dif (/ (- (pict-height emphasized) (segment-height picked-seg)) 2)] - [magnified (pin-over line + [magnified (pin-over line (- aseg-rel-x width-dif) - (- aseg-rel-y height-dif) - emphasized)] - [hover-magnified (if (and showing-tacked - hovered + (- aseg-rel-y height-dif) + emphasized)] + [hover-magnified (if (and showing-tacked + hovered (not (eq? hovered tacked))) - (let* ([hmag (make-stand-out-pict hovered)] + (let* ([hmag (make-stand-out-pict hovered)] [hwidth-dif (/ (- (pict-width hmag) (pict-width (pict-for-segment hovered))) - 2)] + 2)] [hheight-dif (/ (- (pict-height hmag) (pict-height (pict-for-segment hovered))) 2)]) - (pin-over magnified - (- (- (segment-x hovered) (viewable-region-x vregion)) hwidth-dif) + (pin-over magnified + (- (- (segment-x hovered) (viewable-region-x vregion)) hwidth-dif) (- (- (segment-y hovered) (viewable-region-y vregion)) hheight-dif) - hmag)) - magnified)] + hmag)) + magnified)] [arrows (draw-arrows hover-magnified vregion picked-seg)]) arrows)])] [else base])) ;Draw a line from one node on the creation graph to another ;;line-from : drawable-node drawable-node pict viewable-region -> pict -(define (line-from start end pct minx miny) +(define (line-from start end pct minx miny) (define par-center (drawable-node-center start)) (define child-center (drawable-node-center end)) - (draw-line-onto pct + (draw-line-onto pct (- (point-x par-center) minx) (- (point-y par-center) miny) - (- (point-x child-center) minx) - (- (point-y child-center) miny) - (create-graph-edge-color) + (- (point-x child-center) minx) + (- (point-y child-center) miny) + (create-graph-edge-color) #:width 1 #:style 'dot)) ;Draws a circle for a node on the creation graph ;;node-pict : drawable-node -> pict -(define (node-pict dnode) +(define (node-pict dnode) (let* ([ndata (node-data (drawable-node-node dnode))] - [ntext (if (equal? ndata 'runtime-thread) - "RTT" - (format "~a" (event-user-data ndata)))]) - (cc-superimpose (circle-pict (create-graph-node-backcolor) - (create-graph-node-strokecolor) - (drawable-node-width dnode)) + [ntext (if (equal? ndata 'runtime-thread) + "RTT" + (format "~a" (event-user-data ndata)))]) + (cc-superimpose (circle-pict (create-graph-node-backcolor) + (create-graph-node-strokecolor) + (drawable-node-width dnode)) (colorize (text ntext) (create-graph-node-forecolor))))) ;;creation-tree-pict : (listof indexed-future-event) [enni] [enni] [enni] [enni] [enni] [enni] [enni] -> pict -(define (creation-tree-pict events - #:x [x #f] - #:y [y #f] - #:width [width #f] +(define (creation-tree-pict events + #:x [x #f] + #:y [y #f] + #:width [width #f] #:height [height #f] - #:node-width [node-width #f] - #:padding [padding #f] - #:zoom [zoom CREATE-GRAPH-MIN-ZOOM]) - (define tr (build-trace events)) - (define node-diam (if node-width - node-width - CREATE-GRAPH-NODE-DIAMETER)) - (define graph-padding (if padding - padding + #:node-width [node-width #f] + #:padding [padding #f] + #:zoom [zoom CREATE-GRAPH-MIN-ZOOM]) + (define tr (build-trace events)) + (define node-diam (if node-width + node-width + CREATE-GRAPH-NODE-DIAMETER)) + (define graph-padding (if padding + padding CREATE-GRAPH-PADDING)) - (define layout (draw-tree (trace-creation-tree tr) - #:node-width node-diam - #:padding graph-padding - #:zoom zoom)) - (define vregion (if x - (viewable-region x y width height) + (define layout (draw-tree (trace-creation-tree tr) + #:node-width node-diam + #:padding graph-padding + #:zoom zoom)) + (define vregion (if x + (viewable-region x y width height) #f)) (draw-creategraph-pict vregion layout)) - + ;;draw-creategraph-pict : (or/c viewable-region #f) tree-layout -> pict ;; if vregion is #f, return a pict that includes the entire tree -(define (draw-creategraph-pict vregion layout) +(define (draw-creategraph-pict vregion layout) (define rt-root (first (graph-layout-nodes layout))) (define width (inexact->exact (floor (graph-layout-width layout)))) (define height (inexact->exact (floor (graph-layout-height layout)))) - (define base (if vregion + (define base (if vregion (blank (viewable-region-width vregion) (viewable-region-height vregion)) (blank))) (define minx (if vregion (viewable-region-x vregion) 0)) (define miny (if vregion (viewable-region-y vregion) 0)) (define viewable-nodes (if vregion - (filter (λ (n) (in-viewable-region vregion - (drawable-node-x n) - (drawable-node-y n) - (drawable-node-width n) - (drawable-node-width n))) + (filter (λ (n) (in-viewable-region vregion + (drawable-node-x n) + (drawable-node-y n) + (drawable-node-width n) + (drawable-node-width n))) (graph-layout-nodes layout)) (graph-layout-nodes layout))) (define with-arrows (let ([arrow-pct (for/fold ([pct base]) ([node (in-list (graph-layout-nodes layout))]) - (for/fold ([p pct]) ([child (in-list (drawable-node-children node))]) + (for/fold ([p pct]) ([child (in-list (drawable-node-children node))]) (line-from node child p minx miny)))]) - (for/fold ([pct arrow-pct]) ([node (in-list viewable-nodes)]) - (pin-over pct - (- (drawable-node-x node) minx) - (- (drawable-node-y node) miny) + (for/fold ([pct arrow-pct]) ([node (in-list viewable-nodes)]) + (pin-over pct + (- (drawable-node-x node) minx) + (- (drawable-node-y node) miny) (node-pict node))))) (if vregion with-arrows (panorama with-arrows))) (define (zoom-level->factor zoom-level) - (+ 1.0 (* (- zoom-level CREATE-GRAPH-DEFAULT-ZOOM) + (+ 1.0 (* (- zoom-level CREATE-GRAPH-DEFAULT-ZOOM) CREATE-GRAPH-ZOOM-FACTOR))) ;;graph-overlay-pict : drawable-node trace graph-layout -> pict -(define (graph-overlay-pict hover-node tr layout vregion scale-factor) +(define (graph-overlay-pict hover-node tr layout vregion scale-factor) (define (root-sym-or-first-evt n) (node-data (drawable-node-node n))) - (cond - [(or (not hover-node) (equal? (root-sym-or-first-evt hover-node) 'runtime-thread)) + (cond + [(or (not hover-node) (equal? (root-sym-or-first-evt hover-node) 'runtime-thread)) #f] [else (define fid (event-user-data (root-sym-or-first-evt hover-node))) (define ri (hash-ref (trace-future-rtcalls tr) fid #f)) - (cond - [(not ri) #f] - [else - (define block-ops (sort (hash-keys (rtcall-info-block-hash ri)) - > - #:key (λ (p) + (cond + [(not ri) #f] + [else + (define block-ops (sort (hash-keys (rtcall-info-block-hash ri)) + > + #:key (λ (p) (hash-ref (rtcall-info-block-hash ri) p)))) (define sync-ops (sort (hash-keys (rtcall-info-sync-hash ri)) - > - #:key (λ (op) + > + #:key (λ (op) (hash-ref (rtcall-info-sync-hash ri) op)))) - (define-values (node-origin-x node-origin-y) - (values (* (- (drawable-node-x hover-node) (viewable-region-x vregion)) scale-factor) + (define-values (node-origin-x node-origin-y) + (values (* (- (drawable-node-x hover-node) (viewable-region-x vregion)) scale-factor) (* (- (drawable-node-y hover-node) (viewable-region-y vregion)) scale-factor))) - (define-values (center-x center-y) - (values (+ node-origin-x (/ (* (drawable-node-width hover-node) scale-factor) 2)) + (define-values (center-x center-y) + (values (+ node-origin-x (/ (* (drawable-node-width hover-node) scale-factor) 2)) (+ node-origin-y (/ (* (drawable-node-width hover-node) scale-factor) 2)))) (define x (+ center-x CREATE-GRAPH-NODE-DIAMETER)) - (define-values (pct yacc) - (for/fold ([p (pin-over (blank (viewable-region-width vregion) (viewable-region-height vregion)) - node-origin-x - node-origin-y - (scale (node-pict hover-node) scale-factor))] + (define-values (pct yacc) + (for/fold ([p (pin-over (blank (viewable-region-width vregion) (viewable-region-height vregion)) + node-origin-x + node-origin-y + (scale (node-pict hover-node) scale-factor))] [yacc node-origin-y]) - ([rtcall (in-list (append (map (λ (op) (cons 'block op)) block-ops) - (map (λ (op) (cons 'sync op)) sync-ops)))]) - (define evt-type (car rtcall)) + ([rtcall (in-list (append (map (λ (op) (cons 'block op)) block-ops) + (map (λ (op) (cons 'sync op)) sync-ops)))]) + (define evt-type (car rtcall)) (define prim (cdr rtcall)) (define the-hash (if (equal? evt-type 'block) (rtcall-info-block-hash ri) (rtcall-info-sync-hash ri))) - (define txtp (text-pict (format "~a (~a)" - (symbol->string prim) - (hash-ref the-hash prim)) - #:color (get-event-forecolor evt-type))) + (define txtp (text-pict (format "~a (~a)" + (symbol->string prim) + (hash-ref the-hash prim)) + #:color (get-event-forecolor evt-type))) (define txtbg (rect-pict (get-event-color evt-type) - (create-graph-edge-color) - (+ (pict-width txtp) (* TOOLTIP-MARGIN 2)) - (+ (pict-height txtp) (* TOOLTIP-MARGIN 2)) + (create-graph-edge-color) + (+ (pict-width txtp) (* TOOLTIP-MARGIN 2)) + (+ (pict-height txtp) (* TOOLTIP-MARGIN 2)) #:stroke-width .5)) - (values - (pin-over (draw-line-onto p + (values + (pin-over (draw-line-onto p center-x center-y - x - yacc + x + yacc (create-graph-edge-color)) - x - yacc - (pin-over txtbg - TOOLTIP-MARGIN - TOOLTIP-MARGIN - txtp)) + x + yacc + (pin-over txtbg + TOOLTIP-MARGIN + TOOLTIP-MARGIN + txtp)) (+ yacc (pict-height txtbg) CREATE-GRAPH-PADDING)))) pct])])) - \ No newline at end of file diff --git a/collects/future-visualizer/trace.rkt b/collects/future-visualizer/trace.rkt index 67c792a107..36d1cecb94 100644 --- a/collects/future-visualizer/trace.rkt +++ b/collects/future-visualizer/trace.rkt @@ -1,26 +1,26 @@ #lang racket/base -(require racket/contract +(require racket/contract "private/visualizer-data.rkt") -(provide (struct-out future-event) +(provide (struct-out future-event) (struct-out gc-info) - (struct-out indexed-future-event) - trace-futures + (struct-out indexed-future-event) + trace-futures (contract-out - [start-future-tracing! (-> void?)] + [start-future-tracing! (-> void?)] [stop-future-tracing! (-> void?)] [timeline-events (-> (listof indexed-future-event?))] [trace-futures-thunk ((-> any/c) . -> . (listof indexed-future-event?))])) -(define-syntax-rule (trace-futures e ...) - (begin (start-future-tracing!) - (begin (begin e ...) +(define-syntax-rule (trace-futures e ...) + (begin (start-future-tracing!) + (begin (begin e ...) (stop-future-tracing!) (timeline-events)))) ;;trace-futures-thunk : (-> any) -> (listof indexed-future-event) -(define (trace-futures-thunk thunk) - (start-future-tracing!) +(define (trace-futures-thunk thunk) + (start-future-tracing!) (begin - (thunk) + (thunk) (stop-future-tracing!) - (timeline-events))) \ No newline at end of file + (timeline-events))) diff --git a/collects/lang/private/sl-eval.rkt b/collects/lang/private/sl-eval.rkt index 356cc0ec7d..106a37d158 100644 --- a/collects/lang/private/sl-eval.rkt +++ b/collects/lang/private/sl-eval.rkt @@ -1,6 +1,10 @@ #lang racket -(require teachpack/2htdp/scribblings/img-eval racket/sandbox mzlib/pconvert file/convertible scribble/eval) +(require teachpack/2htdp/scribblings/img-eval + racket/sandbox + mzlib/pconvert + file/convertible + scribble/eval) (provide ;; syntax: @@ -110,4 +114,4 @@ (parameterize ([sandbox-namespace-specs (list (lambda () (namespace-anchor->namespace ns)))] [sandbox-error-output 'string] [sandbox-output 'string]) - (make-base-eval))))) \ No newline at end of file + (make-base-eval))))) diff --git a/collects/mzlib/integer-set.rkt b/collects/mzlib/integer-set.rkt index 15112781b7..732e3421c7 100644 --- a/collects/mzlib/integer-set.rkt +++ b/collects/mzlib/integer-set.rkt @@ -9,4 +9,4 @@ count) (rename-out [subtract difference] [symmetric-difference xor] - [count card])) \ No newline at end of file + [count card])) diff --git a/collects/mzlib/process.rkt b/collects/mzlib/process.rkt index ed07ddc196..9f287ee9d4 100644 --- a/collects/mzlib/process.rkt +++ b/collects/mzlib/process.rkt @@ -3,4 +3,4 @@ ;; deprecated library, see `racket/system` (require racket/system) -(provide (all-from-out racket/system)) \ No newline at end of file +(provide (all-from-out racket/system)) diff --git a/collects/scribblings/scribble/renderer.scrbl b/collects/scribblings/scribble/renderer.scrbl index af2d219e60..4d058634e7 100644 --- a/collects/scribblings/scribble/renderer.scrbl +++ b/collects/scribblings/scribble/renderer.scrbl @@ -362,4 +362,4 @@ it saves the resulting files in a different place. that it saves the file @filepath{blueboxes.rktd} in the same directory where each @racket[dests] element resides. }} -} \ No newline at end of file +} diff --git a/collects/stepper/examples/external-interface-example.rkt b/collects/stepper/examples/external-interface-example.rkt index 65d07bf00e..fc142a1b42 100644 --- a/collects/stepper/examples/external-interface-example.rkt +++ b/collects/stepper/examples/external-interface-example.rkt @@ -28,4 +28,4 @@ ;; the file interface: (define-runtime-path bobby "./bobby.rkt") -(step-program-file bobby handler) \ No newline at end of file +(step-program-file bobby handler) diff --git a/collects/tests/drracket/snip/run-all.rkt b/collects/tests/drracket/snip/run-all.rkt index 13764d7fba..e8c0058584 100644 --- a/collects/tests/drracket/snip/run-all.rkt +++ b/collects/tests/drracket/snip/run-all.rkt @@ -46,4 +46,4 @@ (unless (zero? failures) (eprintf "~a attempt~a failed\n" failures - (if (= failures 1) "" "s"))) \ No newline at end of file + (if (= failures 1) "" "s"))) diff --git a/collects/tests/future/trace.rkt b/collects/tests/future/trace.rkt index 20d53fd7bd..52c2335b46 100644 --- a/collects/tests/future/trace.rkt +++ b/collects/tests/future/trace.rkt @@ -94,4 +94,4 @@ Invariants: (define l (trace-futures (let ([f (future (λ () (printf "hello\n")))]) (sleep 0.1) (touch f)))) - (check-equal? l '())]) \ No newline at end of file + (check-equal? l '())]) diff --git a/collects/tests/generic/empty-interface.rkt b/collects/tests/generic/empty-interface.rkt index da30f44d75..3beb276136 100644 --- a/collects/tests/generic/empty-interface.rkt +++ b/collects/tests/generic/empty-interface.rkt @@ -2,4 +2,4 @@ (require racket/generic) (define-generics name) (struct foo () - #:methods gen:name []) \ No newline at end of file + #:methods gen:name []) diff --git a/collects/tests/typed-racket/send-places.rkt b/collects/tests/typed-racket/send-places.rkt index 6c7717c40d..dc4d886779 100644 --- a/collects/tests/typed-racket/send-places.rkt +++ b/collects/tests/typed-racket/send-places.rkt @@ -28,4 +28,4 @@ (place-channel-put enq-ch (vector 'log name dir res-ch*)) (place-channel-get res-ch)] [else - (generate-log/place name dir)])) \ No newline at end of file + (generate-log/place name dir)])) diff --git a/collects/tests/typed-racket/succeed/poly-struct-pred.rkt b/collects/tests/typed-racket/succeed/poly-struct-pred.rkt index ee3fa951e1..afcd2bd70a 100644 --- a/collects/tests/typed-racket/succeed/poly-struct-pred.rkt +++ b/collects/tests/typed-racket/succeed/poly-struct-pred.rkt @@ -6,4 +6,4 @@ (define (f t) (match t [(s value) (s value)] - [_ (error 'fail)])) \ No newline at end of file + [_ (error 'fail)])) diff --git a/collects/typed-racket/env/env-req.rkt b/collects/typed-racket/env/env-req.rkt index dde5ae48e2..e2ea0fe83a 100644 --- a/collects/typed-racket/env/env-req.rkt +++ b/collects/typed-racket/env/env-req.rkt @@ -11,4 +11,4 @@ (dynamic-require (collapse-module-path '(submod "." #%type-decl) m) #f)))) -(provide add-mod! do-requires) \ No newline at end of file +(provide add-mod! do-requires) diff --git a/collects/typed-racket/env/mvar-env.rkt b/collects/typed-racket/env/mvar-env.rkt index 7a4ca5ed28..03ccb027fb 100644 --- a/collects/typed-racket/env/mvar-env.rkt +++ b/collects/typed-racket/env/mvar-env.rkt @@ -10,4 +10,4 @@ (dict-set! mvar-env id #t)) (define (is-var-mutated? id) - (dict-ref mvar-env id #f)) \ No newline at end of file + (dict-ref mvar-env id #f)) diff --git a/collects/typed-racket/utils/disappeared-use.rkt b/collects/typed-racket/utils/disappeared-use.rkt index 2773f8b7a7..7b463de97b 100644 --- a/collects/typed-racket/utils/disappeared-use.rkt +++ b/collects/typed-racket/utils/disappeared-use.rkt @@ -7,4 +7,4 @@ (disappeared-use-todo (cons t (disappeared-use-todo)))) (define disappeared-bindings-todo (make-parameter '())) (define (add-disappeared-binding t) - (disappeared-bindings-todo (cons t (disappeared-bindings-todo)))) \ No newline at end of file + (disappeared-bindings-todo (cons t (disappeared-bindings-todo)))) diff --git a/collects/unstable/open-place.rkt b/collects/unstable/open-place.rkt index a5e518e293..8309fb55d3 100644 --- a/collects/unstable/open-place.rkt +++ b/collects/unstable/open-place.rkt @@ -25,4 +25,4 @@ "free variable values must be allowable as place messages" (symbol->string (syntax-e n)) e))) (place-channel-put p vec) - p)])) \ No newline at end of file + p)]))