suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

added a snipclass for pict-snip

Browse Source
This commit is contained in:
Robby Findler 2012-02-25 20:55:46 -06:00
parent 72b9199976
commit ad65164c5e
2 changed files with 88 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/drracket/private/language.rkt
View File

@ -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))

85
collects/drracket/private/pict-snip.rkt Normal file
View File

@ -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?
#"#<pict-snip>"
(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])))