diff --git a/collects/drracket/private/language.rkt b/collects/drracket/private/language.rkt index 2dfeeace0b..da4fd9a75f 100644 --- a/collects/drracket/private/language.rkt +++ b/collects/drracket/private/language.rkt @@ -26,7 +26,8 @@ compiler/distribute compiler/bundle-dist (prefix-in file: file/convertible) - "rep.rkt") + "rep.rkt" + (prefix-in pict-snip: "pict-snip.rkt")) (import [prefix drracket:debug: drracket:debug^] [prefix drracket:tools: drracket:tools^] @@ -464,36 +465,6 @@ (simple-settings-show-sharing settings))]) (thunk)))) - ;; this snip is created on the user's space, - ;; but its callbacks are invoked on DrRacket's. - (define pict-snip% - (class snip% - (init-field w h d a recorded-datum) - (define/override (get-extent dc x y [wb #f] [hb #f] [descent #f] [space #f] [lspace #f] [rspace #f]) - (set-box/f lspace 0) - (set-box/f rspace 0) - (set-box/f wb w) - (set-box/f hb h) - (set-box/f descent d) - (set-box/f space a)) - (define proc #f) - (define/override (draw dc x y left top right bottom dx dy draw-caret) - (unless proc - (set! proc (with-handlers ((exn:fail? (λ (x) - (λ (dc) - (define clr (send dc get-text-foreground)) - (send dc set-text-foreground "red") - (send dc draw-text (exn-message x) 0 0) - (send dc set-text-foreground clr))))) - (recorded-datum->procedure recorded-datum))) - (set! recorded-datum #f)) - (define-values (ox oy) (send dc get-origin)) - (send dc set-origin (+ dx x) (+ dy y)) - (proc dc) - (send dc set-origin ox oy)) - (define/override (copy) (new pict-snip% [w w] [h h] [d d] [a a] - [recorded-datum recorded-datum])) - (super-new))) (define (mk-pict-snip convertible) (define-syntax-rule @@ -507,10 +478,8 @@ (define rdc (new record-dc%)) (dyn draw-pict pict rdc 0 0) (define recorded-datum (send rdc get-recorded-datum)) - (new pict-snip% [w w] [h h] [d d] [a a] [recorded-datum recorded-datum])) + (new pict-snip:pict-snip% [w w] [h h] [d d] [a a] [recorded-datum recorded-datum])) - (define (set-box/f b v) (when (box? b) (set-box! b v))) - ;; drscheme-inspector : inspector (define drscheme-inspector (current-inspector)) diff --git a/collects/drracket/private/pict-snip.rkt b/collects/drracket/private/pict-snip.rkt new file mode 100644 index 0000000000..9b65e456a7 --- /dev/null +++ b/collects/drracket/private/pict-snip.rkt @@ -0,0 +1,85 @@ +#lang racket/base +(require racket/snip + racket/class + racket/match + racket/draw + wxme + (prefix-in r: racket/base)) + +(provide pict-snip% snip-class) + +;; this snip is created on the user's space, +;; but its callbacks are invoked on DrRacket's. +(define pict-snip% + (class snip% + (init-field w h d a recorded-datum) + (define/override (get-extent dc x y [wb #f] [hb #f] [descent #f] [space #f] [lspace #f] [rspace #f]) + (set-box/f lspace 0) + (set-box/f rspace 0) + (set-box/f wb w) + (set-box/f hb h) + (set-box/f descent d) + (set-box/f space a)) + (define proc #f) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (unless proc + (set! proc (with-handlers ((exn:fail? mk-error-drawer)) + (recorded-datum->procedure recorded-datum)))) + (define-values (ox oy) (send dc get-origin)) + (send dc set-origin (+ ox x) (+ oy y)) + (proc dc) + (send dc set-origin ox oy)) + (define/override (copy) (new pict-snip% [w w] [h h] [d d] [a a] + [recorded-datum recorded-datum])) + + (define/override (write f) + (define prt (open-output-bytes)) + (r:write (list w h d a recorded-datum) prt) + (define bytes (get-output-bytes prt)) + (send f put (bytes-length bytes) bytes)) + (super-new) + (inherit set-snipclass) + (set-snipclass snip-class))) + +(define (set-box/f b v) (when (box? b) (set-box! b v))) + +(define ((mk-error-drawer exn) dc) + (define clr (send dc get-text-foreground)) + (send dc set-text-foreground "red") + (send dc draw-text (exn-message exn) 0 0) + (send dc set-text-foreground clr)) + +(define snip-class + (new (class snip-class% + (define/override (read f) + (parse-pict-snip-from-bytes + (send f get-unterminated-bytes))) + (super-new)))) + +(send snip-class set-classname (format "~s" (list '(lib "pict-snip.rkt" "drracket" "private") + '(lib "pict-snip.rkt" "drracket" "private")))) +(send (get-the-snip-class-list) add snip-class) + +(define reader + (class* object% (snip-reader<%>) + (define/public (read-header version stream) (void)) + (define/public (read-snip text-only? version stream) + (define bytes (send stream read-raw-bytes 'pict-snip)) + (if text-only? + #"#" + (or (parse-pict-snip-from-bytes bytes) + (error 'pict-snip.rkt "could not read pict-snip from stream")))) + (super-new))) + +;; parse-pict-snip-from-bytes : bytes -> (or/c (is-a?/c pict-snip%) #f) +(define (parse-pict-snip-from-bytes bytes) + (let/ec escape + (define prt (open-input-bytes bytes)) + (define sexp (with-handlers ((exn:fail:read? (λ (x) (escape #f)))) + (read prt))) + (match sexp + [`(,(? real? w) ,(? real? h) ,(? real? d) ,(? real? a) ,recorded-datum) + (new pict-snip% [w w] [h h] [d d] [a a] + [recorded-datum recorded-datum])] + [else + #f])))