155 lines
4.9 KiB
Scheme
155 lines
4.9 KiB
Scheme
|
|
(module syntax-snip mzscheme
|
|
(require (lib "class.ss")
|
|
(lib "mred.ss" "mred")
|
|
"interfaces.ss"
|
|
"prefs.ss"
|
|
"properties.ss"
|
|
"typesetter.ss"
|
|
"widget.ss"
|
|
"partition.ss")
|
|
(provide syntax-snip%
|
|
super-syntax-snip%)
|
|
|
|
(define current-syntax-controller (make-parameter #f))
|
|
|
|
(define (the-syntax-controller)
|
|
(let ([controller (current-syntax-controller)])
|
|
(or controller
|
|
(let ([controller (new syntax-controller%)])
|
|
(current-syntax-controller controller)
|
|
controller))))
|
|
|
|
|
|
;; syntax-snip%
|
|
(define syntax-snip%
|
|
(class* editor-snip% ()
|
|
(init-field ((stx syntax)))
|
|
(init-field controller)
|
|
|
|
(define -outer (new text%))
|
|
(super-new (editor -outer))
|
|
|
|
;; Initialization
|
|
(send -outer begin-edit-sequence)
|
|
(initialize -outer)
|
|
(outer:insert "Syntax browser" style:bold)
|
|
(outer:insert " ")
|
|
(outer:insert "Clear" style:hyper
|
|
(lambda (x y z) (send controller select-syntax #f)))
|
|
(outer:insert " ")
|
|
(outer:insert "Properties" style:hyper
|
|
(lambda (x y z)
|
|
(send (send controller get-properties-controller)
|
|
show #t)))
|
|
(outer:insert "\n")
|
|
(new typesetter-for-text%
|
|
(syntax stx)
|
|
(controller controller)
|
|
(text -outer))
|
|
(send -outer lock #t)
|
|
(send -outer end-edit-sequence)
|
|
(send -outer hide-caret #t)
|
|
|
|
(define/public (initialize outer)
|
|
(void))
|
|
|
|
(define/private outer:insert
|
|
(case-lambda
|
|
[(obj)
|
|
(outer:insert obj style:normal)]
|
|
[(text style)
|
|
(outer:insert text style #f)]
|
|
[(text style clickback)
|
|
(let ([start (send -outer last-position)])
|
|
(send -outer insert text)
|
|
(let ([end (send -outer last-position)])
|
|
(send -outer change-style style start end #f)
|
|
(when clickback
|
|
(send -outer set-clickback start end clickback))))]))
|
|
|
|
;; snip% Methods
|
|
|
|
(define/override (copy)
|
|
(new syntax-snip% (controller controller) (syntax stx)))
|
|
|
|
))
|
|
|
|
(define subservient-syntax-snip%
|
|
(class syntax-snip%
|
|
(init-field f)
|
|
(define/override (initialize outer)
|
|
(f outer))
|
|
(super-new)))
|
|
|
|
(define style:normal (make-object style-delta% 'change-normal))
|
|
(define style:hyper
|
|
(let ([s (make-object style-delta% 'change-normal)])
|
|
(send s set-delta 'change-toggle-underline)
|
|
(send s set-delta-foreground "blue")
|
|
s))
|
|
(define style:bold
|
|
(let ([s (make-object style-delta% 'change-normal)])
|
|
(send s set-delta 'change-bold)
|
|
s))
|
|
|
|
(define (show-icon) (make-object image-snip% (build-path (collection-path "icons") "turn-up.png")))
|
|
(define (hide-icon) (make-object image-snip% (build-path (collection-path "icons") "turn-down.png")))
|
|
|
|
(define super-syntax-snip%
|
|
(class* editor-snip% ()
|
|
(init-field ((stx syntax)))
|
|
(init-field (controller (the-syntax-controller)))
|
|
|
|
(define -outer (new text%))
|
|
(super-new (editor -outer) (with-border? #f))
|
|
|
|
(define/private (hide-me)
|
|
(send* -outer
|
|
(lock #f)
|
|
(erase))
|
|
(outer:insert (show-icon) style:hyper (lambda _ (show-me)))
|
|
(outer:insert "#<syntax>")
|
|
(send -outer lock #t))
|
|
|
|
(define/private (show-me)
|
|
(send* -outer
|
|
(lock #f)
|
|
(erase))
|
|
(outer:insert (new subservient-syntax-snip%
|
|
(syntax stx)
|
|
(controller controller)
|
|
(f (lambda (t)
|
|
(let* ([start (send t last-position)]
|
|
[_ (send t insert (hide-icon))]
|
|
[end (send t last-position)])
|
|
(send t insert " ")
|
|
(send t change-style style:hyper start end #f)
|
|
(send t set-clickback start end (lambda _ (hide-me))))))))
|
|
(send* -outer
|
|
(lock #t)))
|
|
|
|
(define/private outer:insert
|
|
(case-lambda
|
|
[(obj)
|
|
(outer:insert obj style:normal)]
|
|
[(text style)
|
|
(outer:insert text style #f)]
|
|
[(text style clickback)
|
|
(let ([start (send -outer last-position)])
|
|
(send -outer insert text)
|
|
(let ([end (send -outer last-position)])
|
|
(send -outer change-style style start end #f)
|
|
(when clickback
|
|
(send -outer set-clickback start end clickback))))]))
|
|
|
|
(define/override (copy)
|
|
(new super-syntax-snip% (controller controller) (syntax stx)))
|
|
|
|
(hide-me)
|
|
(send -outer hide-caret #t)
|
|
(send -outer lock #t)
|
|
))
|
|
|
|
)
|