056683743d
updated to change in expansion of lexical variables many UI updates and tweaks improved syntax properties panel added expand-only and expand/hide added rudimentary textual stepper fixed PR 8395 by adding snipclass for hrule-snip fixed PR 8431: reductions and block splicing fixed PR 8433: handling unquote and macro hiding w/ errors in hidden terms svn: r5120
58 lines
1.8 KiB
Scheme
58 lines
1.8 KiB
Scheme
|
|
(module hrule-snip mzscheme
|
|
(require (lib "class.ss")
|
|
(lib "mred.ss" "mred"))
|
|
(provide hrule-snip%)
|
|
|
|
;; hrule-snip%
|
|
;; A snip for drawing horizontal separating lines.
|
|
(define hrule-snip%
|
|
(class snip%
|
|
(inherit get-admin)
|
|
(define/override (get-extent dc x y bw bh bdescent bspace blspace brspace)
|
|
(let-values [((h) (get-xheight dc))
|
|
((fw fh) (send dc get-size))]
|
|
(let ([ad-x (box 0)]
|
|
[ad-y (box 0)])
|
|
(send (get-admin) get-view-size ad-x ad-y)
|
|
#;(set-box?! bw fw)
|
|
(set-box?! bw (max 0 (- (unbox ad-x) (get-xheight dc))))
|
|
(set-box?! bh h))))
|
|
(define/override (draw dc x y left top right bottom dx dy draw-caret)
|
|
(let* [(xh (get-xheight dc))
|
|
(ny (+ y (/ xh 2)))]
|
|
(send dc draw-line x ny right ny)))
|
|
(define/private (set-box?! b v)
|
|
(when (box? b) (set-box! b v)))
|
|
(define/private (get-xheight dc)
|
|
(or cached-xheight
|
|
(let-values [((w h descent extra) (send dc get-text-extent "x"))]
|
|
(set! cached-xheight h)
|
|
h)))
|
|
(define cached-xheight #f)
|
|
|
|
;; Snip methods
|
|
(define/override (copy)
|
|
(new hrule-snip%))
|
|
(define/override (write stream)
|
|
(void))
|
|
(inherit set-snipclass)
|
|
(super-new)
|
|
|
|
(set-snipclass snip-class)))
|
|
|
|
|
|
(define hrule-snipclass%
|
|
(class snip-class%
|
|
(define/override (read stream)
|
|
(let ([str (send stream get-bytes)])
|
|
(new hrule-snip%)))
|
|
(super-new)))
|
|
|
|
(define snip-class (new hrule-snipclass%))
|
|
(send snip-class set-version 1)
|
|
(send snip-class set-classname
|
|
(format "~s" '(lib "hrule-snip.ss" "macro-debugger" "syntax-browser")))
|
|
(send (get-the-snip-class-list) add snip-class)
|
|
)
|