(module rml-snips mzscheme
(require (lib "class.ss")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework"))
(provide hrule-snip%
collapse-box-snip%)
(define hrule-snip%
(class* snip% ()
(override get-extent
draw)
(define cached-xheight #f)
(define (get-xheight dc)
(or cached-xheight
(let-values [((w h descent extra) (send dc get-text-extent "x"))]
(set! cached-xheight h)
h)))
(define (get-extent dc x y bw bh bdescent bspace blspace brspace)
(let-values [((h) (get-xheight dc))
((fw fh) (send dc get-size))]
(define (set-box?! b v)
(when (box? b) (set-box! b v)))
(set-box?! bw fw)
(set-box?! bh h)))
(define (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)))
(super-instantiate ())
))
(define expand-img
(make-object bitmap% (build-path (collection-path "icons") "turn-up.gif")))
(define collapse-img
(make-object bitmap% (build-path (collection-path "icons") "turn-down.gif")))
(define collapse-box-snip%
(class* editor-snip% ()
(init-field renderer)
(init-field collapsed-rml
expanded-rml)
(inherit show-border
set-tight-text-fit)
(public expand
collapse)
(define expanded? #t)
(define cmd-expand-snip (make-object image-snip% expand-img))
(define cmd-collapse-snip (make-object image-snip% collapse-img))
(define outer-t (instantiate (text:hide-caret/selection-mixin scheme:text%) ()))
(define collapsed (instantiate rml-display/snip% () (renderer renderer)))
(define expanded (instantiate rml-display/snip% () (renderer renderer)))
(send collapsed display/tail
`(span ()
(link ,(lambda _ (expand)) () ,cmd-expand-snip)
,collapsed-rml))
(send expanded display/tail
`(div ()
(div ()
(link ,(lambda _ (collapse)) () ,cmd-collapse-snip)
,collapsed-rml)
,expanded-rml))
(send (send collapsed get-snip) show-border #f)
(send* (send collapsed get-editor)
(hide-caret #t)
(lock #t))
(send (send expanded get-snip) show-border #f)
(send* (send expanded get-editor)
(hide-caret #t)
(lock #t))
(define (expand)
(unless expanded?
(send outer-t lock #f)
(show-border #t)
(set-tight-text-fit #f)
(send outer-t release-snip cmd-expand-snip)
(send outer-t release-snip (send collapsed get-snip))
(send outer-t erase)
(send outer-t insert cmd-collapse-snip)
(send outer-t insert (send expanded get-snip))
(send outer-t lock #t)
(set! expanded? #t)))
(define (collapse)
(when expanded?
(send outer-t lock #f)
(show-border #f)
(set-tight-text-fit #t)
(send outer-t release-snip cmd-collapse-snip)
(send outer-t release-snip (send expanded get-snip))
(send outer-t erase)
(send outer-t insert (send collapsed get-snip))
(send outer-t lock #t)
(set! expanded? #f)))
(super-instantiate ()
(editor outer-t) (with-border? #f)
(left-margin 3) (right-margin 0) (top-margin 0) (bottom-margin 0)
(left-inset 1) (top-inset 0) (right-inset 0) (bottom-inset 0))
(collapse)
))
)