From 4e47aff061f015b85f13b2122e3be428e5ab0f39 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 14 Jan 2011 20:15:26 -0700 Subject: [PATCH] clean up code that adds date and filename to DrRacket printout --- although I don't think it should be added at all, or maybe added only if a preference is set --- collects/drracket/private/unit.rkt | 29 +++++++++++++++-------------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 04d5c139c1..3e5858315f 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -486,7 +486,8 @@ module browser threading seems wrong. text:info%)))))))))))]) ((get-program-editor-mixin) (class* definitions-super% (definitions-text<%>) - (inherit get-top-level-window is-locked? lock while-unlocked highlight-first-line) + (inherit get-top-level-window is-locked? lock while-unlocked highlight-first-line + is-printing?) (define interactions-text #f) (define/public (set-interactions-text it) @@ -739,8 +740,6 @@ module browser threading seems wrong. (is-lang-line? l))) (inherit get-filename) - (field - [tmp-date-string #f]) (inherit get-filename/untitled-name) (define/private (get-date-string) @@ -750,18 +749,20 @@ module browser threading seems wrong. (get-filename/untitled-name))) (define/override (on-paint before dc left top right bottom dx dy draw-caret) - (when (and before - (or (is-a? dc post-script-dc%) - (is-a? dc printer-dc%))) - (set! tmp-date-string (get-date-string)) - (let-values ([(w h d s) (send dc get-text-extent tmp-date-string)]) - (send (current-ps-setup) set-editor-margin 0 (inexact->exact (ceiling h))))) (super on-paint before dc left top right bottom dx dy draw-caret) - (when (and (not before) - (or (is-a? dc post-script-dc%) - (is-a? dc printer-dc%))) - (send dc draw-text (get-date-string) 0 0) - (void)) + + ;; For printing, put date and filename in the top margin: + (when (and before (is-printing?)) + (let ([h (box 0)] + [w (box 0)]) + (send (current-ps-setup) get-editor-margin w h) + (unless ((unbox h) . < . 2) + (let ([font (make-font #:size (inexact->exact (ceiling (* 1/2 (unbox h)))) + #:family 'modern)] + [old-font (send dc get-font)]) + (send dc set-font font) + (send dc draw-text (get-date-string) 0 0) + (send dc set-font old-font))))) ;; draw the arrows (when before